diff options
Diffstat (limited to 'stdlib')
118 files changed, 23729 insertions, 0 deletions
diff --git a/stdlib/README.md b/stdlib/README.md new file mode 100644 index 000000000..454228d07 --- /dev/null +++ b/stdlib/README.md @@ -0,0 +1,15 @@ +# stdlib +Standard library for the Lux family of programming languages. + +### How do I get it? + +Just add this to your Leiningen dependencies when building Lux programs: +``` +[com.github.luxlang/lux-stdlib "0.3.3"] +``` + +You can find the Leiningen plugin for Lux over here: https://github.com/LuxLang/lux-lein + +### How do I use it? + +You can see what's available here: https://github.com/LuxLang/lux/wiki/Standard-Library diff --git a/stdlib/license.txt b/stdlib/license.txt new file mode 100644 index 000000000..52d135112 --- /dev/null +++ b/stdlib/license.txt @@ -0,0 +1,374 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. + diff --git a/stdlib/project.clj b/stdlib/project.clj new file mode 100644 index 000000000..287a2f803 --- /dev/null +++ b/stdlib/project.clj @@ -0,0 +1,19 @@ +(defproject com.github.luxlang/lux-stdlib "0.5.0-SNAPSHOT" + :description "Standard library for the Lux programming language." + :url "https://github.com/LuxLang/stdlib" + :license {:name "Mozilla Public License (Version 2.0)" + :url "https://www.mozilla.org/en-US/MPL/2.0/"} + :plugins [[com.github.luxlang/lein-luxc "0.5.0-SNAPSHOT"]] + :deploy-repositories [["releases" {:url "https://oss.sonatype.org/service/local/staging/deploy/maven2/" + :creds :gpg}] + ["snapshots" {:url "https://oss.sonatype.org/content/repositories/snapshots/" + :creds :gpg}]] + :pom-addition [:developers [:developer + [:name "Eduardo Julian"] + [:url "https://github.com/eduardoejp"]]] + :repositories [["snapshots" "https://oss.sonatype.org/content/repositories/snapshots/"] + ["releases" "https://oss.sonatype.org/service/local/staging/deploy/maven2/"]] + :source-paths ["source"] + :test-paths ["test"] + :lux {:tests "tests"} + ) diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux new file mode 100644 index 000000000..2b66cdbe1 --- /dev/null +++ b/stdlib/source/lux.lux @@ -0,0 +1,5541 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +## Basic types +(_lux_def Bool + (+12 ["lux" "Bool"] + (+0 "java.lang.Boolean" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Nat + (+12 ["lux" "Nat"] + (+0 "#Nat" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Int + (+12 ["lux" "Int"] + (+0 "java.lang.Long" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Real + (+12 ["lux" "Real"] + (+0 "java.lang.Double" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Frac + (+12 ["lux" "Frac"] + (+0 "#Frac" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Char + (+12 ["lux" "Char"] + (+0 "java.lang.Character" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Text + (+12 ["lux" "Text"] + (+0 "java.lang.String" (+0))) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Void + (+12 ["lux" "Void"] + (+1)) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Unit + (+12 ["lux" "Unit"] + (+2)) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +(_lux_def Ident + (+12 ["lux" "Ident"] + (+4 Text Text)) + (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0)))) + +## (type: (List a) +## #Nil +## (#Cons a (List a))) +(_lux_def List + (+12 ["lux" "List"] + (+9 (+0) + (+3 ## "lux;Nil" + (+2) + ## "lux;Cons" + (+4 (+6 +1) + (+11 (+6 +0) (+6 +1)))))) + (+1 [["lux" "type?"] (+0 true)] + (+1 [["lux" "export?"] (+0 true)] + (+1 [["lux" "tags"] (+8 (+1 (+6 "Nil") (+1 (+6 "Cons") (+0))))] + (+1 [["lux" "type-args"] (+8 (+1 (+6 "a") (+0)))] + (+0)))))) + +## (type: (Maybe a) +## #None +## (#Some a)) +(_lux_def Maybe + (+12 ["lux" "Maybe"] + (+9 (+0) + (+3 ## "lux;None" + (+2) + ## "lux;Some" + (+6 +1)))) + (#Cons [["lux" "type?"] (+0 true)] + (#Cons [["lux" "export?"] (+0 true)] + (#Cons [["lux" "tags"] (+8 (#Cons (+6 "None") (#Cons (+6 "Some") #Nil)))] + (#Cons [["lux" "type-args"] (+8 (#Cons (+6 "a") #Nil))] + #Nil))))) + +## (type: #rec Type +## (#HostT Text (List Type)) +## #VoidT +## #UnitT +## (#SumT Type Type) +## (#ProdT Type Type) +## (#LambdaT Type Type) +## (#BoundT Nat) +## (#VarT Nat) +## (#ExT Nat) +## (#UnivQ (List Type) Type) +## (#ExQ (List Type) Type) +## (#AppT Type Type) +## (#NamedT Ident Type) +## ) +(_lux_def Type + (+12 ["lux" "Type"] + (_lux_case (+11 (+6 +0) (+6 +1)) + Type + (_lux_case (+11 List Type) + TypeList + (_lux_case (+4 Type Type) + TypePair + (+11 (+9 (+0) + (+3 ## "lux;HostT" + (+4 Text TypeList) + (+3 ## "lux;VoidT" + (+2) + (+3 ## "lux;UnitT" + (+2) + (+3 ## "lux;SumT" + TypePair + (+3 ## "lux;ProdT" + TypePair + (+3 ## "lux;LambdaT" + TypePair + (+3 ## "lux;BoundT" + Nat + (+3 ## "lux;VarT" + Nat + (+3 ## "lux;ExT" + Nat + (+3 ## "lux;UnivQ" + (+4 TypeList Type) + (+3 ## "lux;ExQ" + (+4 TypeList Type) + (+3 ## "lux;AppT" + TypePair + ## "lux;NamedT" + (+4 Ident Type)))))))))))))) + Void))))) + (#Cons [["lux" "type?"] (+0 true)] + (#Cons [["lux" "export?"] (+0 true)] + (#Cons [["lux" "tags"] (+8 (#Cons (+6 "HostT") + (#Cons (+6 "VoidT") + (#Cons (+6 "UnitT") + (#Cons (+6 "SumT") + (#Cons (+6 "ProdT") + (#Cons (+6 "LambdaT") + (#Cons (+6 "BoundT") + (#Cons (+6 "VarT") + (#Cons (+6 "ExT") + (#Cons (+6 "UnivQ") + (#Cons (+6 "ExQ") + (#Cons (+6 "AppT") + (#Cons (+6 "NamedT") + #Nil))))))))))))))] + (#Cons [["lux" "doc"] (+6 "This type represents the data-structures that are used to specify types themselves.")] + (#Cons [["lux" "type-rec?"] (+0 true)] + #Nil)))))) + +## (type: Top +## (Ex [a] a)) +(_lux_def Top + (#NamedT ["lux" "Top"] + (#ExQ (+0) (#BoundT +1))) + (#Cons [["lux" "type?"] (+0 true)] + (#Cons [["lux" "export?"] (+0 true)] + (#Cons [["lux" "doc"] (+6 "The type of things whose type doesn't matter. + It can be used to write functions or data-structures that can take, or return anything.")] + #Nil)))) + +## (type: Bottom +## (All [a] a)) +(_lux_def Bottom + (#NamedT ["lux" "Bottom"] + (#UnivQ (+0) (#BoundT +1))) + (#Cons [["lux" "type?"] (+0 true)] + (#Cons [["lux" "export?"] (+0 true)] + (#Cons [["lux" "doc"] (+6 "The type of things whose type is unknown or undefined. + Useful for expressions that cause errors or other \"extraordinary\" conditions.")] + #Nil)))) + +## (type: #rec Ann-Value +## (#BoolM Bool) +## (#NatM Nat) +## (#IntM Int) +## (#FracM Frac) +## (#RealM Real) +## (#CharM Char) +## (#TextM Text) +## (#IdentM Ident) +## (#ListM (List Ann-Value)) +## (#DictM (List [Text Ann-Value]))) +(_lux_def Ann-Value + (#NamedT ["lux" "Ann-Value"] + (_lux_case (#AppT (#BoundT +0) (#BoundT +1)) + Ann-Value + (#AppT (#UnivQ #Nil + (#SumT ## #BoolM + Bool + (#SumT ## #NatM + Nat + (#SumT ## #IntM + Int + (#SumT ## #FracM + Frac + (#SumT ## #RealM + Real + (#SumT ## #CharM + Char + (#SumT ## #TextM + Text + (#SumT ## #IdentM + Ident + (#SumT ## #ListM + (#AppT List Ann-Value) + ## #DictM + (#AppT List (#ProdT Text Ann-Value))))))))))) + ) + Void) + )) + (#Cons [["lux" "type?"] (+0 true)] + (#Cons [["lux" "export?"] (+0 true)] + (#Cons [["lux" "tags"] (+8 (#Cons (+6 "BoolM") + (#Cons (+6 "NatM") + (#Cons (+6 "IntM") + (#Cons (+6 "FracM") + (#Cons (+6 "RealM") + (#Cons (+6 "CharM") + (#Cons (+6 "TextM") + (#Cons (+6 "IdentM") + (#Cons (+6 "ListM") + (#Cons (+6 "DictM") + #Nil)))))))))))] + (#Cons [["lux" "type-rec?"] (+0 true)] + #Nil))))) + +## (type: Anns +## (List [Ident Ann-Value])) +(_lux_def Anns + (#NamedT ["lux" "Anns"] + (#AppT List (#ProdT Ident Ann-Value))) + (#Cons [["lux" "type?"] (#BoolM true)] + (#Cons [["lux" "export?"] (#BoolM true)] + #Nil))) + +(_lux_def default-def-meta-exported + (_lux_: Anns + (#Cons [["lux" "type?"] (#BoolM true)] + (#Cons [["lux" "export?"] (#BoolM true)] + #Nil))) + #Nil) + +(_lux_def default-def-meta-unexported + (_lux_: Anns + (#Cons [["lux" "type?"] (#BoolM true)] + #Nil)) + #Nil) + +## (type: Def +## [Type Anns Unit]) +(_lux_def Def + (#NamedT ["lux" "Def"] + (#ProdT Type (#ProdT Anns Unit))) + default-def-meta-exported) + +## (type: (Bindings k v) +## {#counter Nat +## #mappings (List [k v])}) +(_lux_def Bindings + (#NamedT ["lux" "Bindings"] + (#UnivQ #Nil + (#UnivQ #Nil + (#ProdT ## "lux;counter" + Nat + ## "lux;mappings" + (#AppT List + (#ProdT (#BoundT +3) + (#BoundT +1))))))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "counter") + (#Cons (#TextM "mappings") + #Nil)))] + (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "k") (#Cons (#TextM "v") #;Nil)))] + default-def-meta-exported))) + +## (type: Cursor +## {#module Text +## #line Int +## #column Int}) +(_lux_def Cursor + (#NamedT ["lux" "Cursor"] + (#ProdT Text (#ProdT Int Int))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "module") + (#Cons (#TextM "line") + (#Cons (#TextM "column") + #Nil))))] + (#Cons [["lux" "doc"] (#TextM "Cursors are for specifying the location of AST nodes in Lux files during compilation.")] + default-def-meta-exported))) + +## (type: (Meta m v) +## {#meta m +## #datum v}) +(_lux_def Meta + (#NamedT ["lux" "Meta"] + (#UnivQ #Nil + (#UnivQ #Nil + (#ProdT (#BoundT +3) + (#BoundT +1))))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "meta") + (#Cons (#TextM "datum") + #Nil)))] + (#Cons [["lux" "doc"] (#TextM "The type of things that can have meta-data of arbitrary types.")] + (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "m") (#Cons (#TextM "v") #;Nil)))] + default-def-meta-exported)))) + +(_lux_def Analysis + (#NamedT ["lux" "Analysis"] + (#AppT (#AppT Meta + (#ProdT Type Cursor)) + Void)) + default-def-meta-exported) + +## (type: Scope +## {#name (List Text) +## #inner-closures Int +## #locals (Bindings Text Analysis) +## #closure (Bindings Text Analysis)}) +(_lux_def Scope + (#NamedT ["lux" "Scope"] + (#ProdT ## "lux;name" + (#AppT List Text) + (#ProdT ## "lux;inner-closures" + Int + (#ProdT ## "lux;locals" + (#AppT (#AppT Bindings Text) Analysis) + ## "lux;closure" + (#AppT (#AppT Bindings Text) Analysis))))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "name") + (#Cons (#TextM "inner-closures") + (#Cons (#TextM "locals") + (#Cons (#TextM "closure") + #Nil)))))] + default-def-meta-exported)) + +## (type: (AST' w) +## (#BoolS Bool) +## (#NatS Nat) +## (#IntS Int) +## (#FracS Frac) +## (#RealS Real) +## (#CharS Char) +## (#TextS Text) +## (#SymbolS Text Text) +## (#TagS Text Text) +## (#FormS (List (w (AST' w)))) +## (#TupleS (List (w (AST' w)))) +## (#RecordS (List [(w (AST' w)) (w (AST' w))]))) +(_lux_def AST' + (#NamedT ["lux" "AST'"] + (_lux_case (#AppT (#BoundT +1) + (#AppT (#BoundT +0) + (#BoundT +1))) + AST + (_lux_case (#AppT [List AST]) + ASTList + (#UnivQ #Nil + (#SumT ## "lux;BoolS" + Bool + (#SumT ## "lux;NatS" + Nat + (#SumT ## "lux;IntS" + Int + (#SumT ## "lux;FracS" + Frac + (#SumT ## "lux;RealS" + Real + (#SumT ## "lux;CharS" + Char + (#SumT ## "lux;TextS" + Text + (#SumT ## "lux;SymbolS" + Ident + (#SumT ## "lux;TagS" + Ident + (#SumT ## "lux;FormS" + ASTList + (#SumT ## "lux;TupleS" + ASTList + ## "lux;RecordS" + (#AppT List (#ProdT AST AST)) + ))))))))))) + )))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "BoolS") + (#Cons (#TextM "NatS") + (#Cons (#TextM "IntS") + (#Cons (#TextM "FracS") + (#Cons (#TextM "RealS") + (#Cons (#TextM "CharS") + (#Cons (#TextM "TextS") + (#Cons (#TextM "SymbolS") + (#Cons (#TextM "TagS") + (#Cons (#TextM "FormS") + (#Cons (#TextM "TupleS") + (#Cons (#TextM "RecordS") + #Nil)))))))))))))] + (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "w") #;Nil))] + default-def-meta-exported))) + +## (type: AST +## (Meta Cursor (AST' (Meta Cursor)))) +(_lux_def AST + (#NamedT ["lux" "AST"] + (_lux_case (#AppT Meta Cursor) + w + (#AppT w (#AppT AST' w)))) + (#Cons [["lux" "doc"] (#TextM "The type of AST nodes for Lux syntax.")] + default-def-meta-exported)) + +(_lux_def ASTList + (#AppT List AST) + default-def-meta-unexported) + +## (type: (Either l r) +## (#Left l) +## (#Right r)) +(_lux_def Either + (#NamedT ["lux" "Either"] + (#UnivQ #Nil + (#UnivQ #Nil + (#SumT ## "lux;Left" + (#BoundT +3) + ## "lux;Right" + (#BoundT +1))))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "Left") + (#Cons (#TextM "Right") + #Nil)))] + (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "l") (#Cons (#TextM "r") #;Nil)))] + default-def-meta-exported))) + +## (type: Source +## (List (Meta Cursor Text))) +(_lux_def Source + (#NamedT ["lux" "Source"] + (#AppT [List + (#AppT [(#AppT [Meta Cursor]) + Text])])) + default-def-meta-exported) + +## (type: Module +## {#module-hash Int +## #module-aliases (List [Text Text]) +## #defs (List [Text Def]) +## #imports (List Text) +## #tags (List [Text [Nat (List Ident) Bool Type]]) +## #types (List [Text [(List Ident) Bool Type]])} +## #module-anns Anns +## ) +(_lux_def Module + (#NamedT ["lux" "Module"] + (#ProdT ## "lux;module-hash" + Int + (#ProdT ## "lux;module-aliases" + (#AppT List (#ProdT Text Text)) + (#ProdT ## "lux;defs" + (#AppT List (#ProdT Text + Def)) + (#ProdT ## "lux;imports" + (#AppT List Text) + (#ProdT ## "lux;tags" + (#AppT List + (#ProdT Text + (#ProdT Nat + (#ProdT (#AppT List Ident) + (#ProdT Bool + Type))))) + (#ProdT ## "lux;types" + (#AppT List + (#ProdT Text + (#ProdT (#AppT List Ident) + (#ProdT Bool + Type)))) + ## "lux;module-anns" + Anns) + )))))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "module-hash") + (#Cons (#TextM "module-aliases") + (#Cons (#TextM "defs") + (#Cons (#TextM "imports") + (#Cons (#TextM "tags") + (#Cons (#TextM "types") + (#Cons (#TextM "module-anns") + #Nil))))))))] + default-def-meta-exported)) + +## (type: CompilerMode +## #Release +## #Debug +## #Eval +## #REPL) +(_lux_def CompilerMode + (#NamedT ["lux" "CompilerMode"] + (#SumT ## "lux;Release" + #UnitT + (#SumT ## "lux;Debug" + #UnitT + (#SumT ## "lux;Eval" + #UnitT + ## "lux;REPL" + #UnitT)))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "Release") + (#Cons (#TextM "Debug") + (#Cons (#TextM "Eval") + (#Cons (#TextM "REPL") + #Nil)))))] + default-def-meta-exported)) + +## (type: CompilerInfo +## {#compiler-name Text +## #compiler-version Text +## #compiler-mode CompilerMode}) +(_lux_def CompilerInfo + (#NamedT ["lux" "CompilerInfo"] + (#ProdT ## "lux;compiler-name" + Text + (#ProdT ## "lux;compiler-version" + Text + ## "lux;compiler-mode" + CompilerMode))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "compiler-name") + (#Cons (#TextM "compiler-version") + (#Cons (#TextM "compiler-mode") + #Nil))))] + default-def-meta-exported)) + +## (type: Compiler +## {#info CompilerInfo +## #source Source +## #cursor Cursor +## #modules (List [Text Module]) +## #scopes (List Scope) +## #type-vars (Bindings Nat (Maybe Type)) +## #expected (Maybe Type) +## #seed Nat +## #scope-type-vars (List Nat) +## #host Void}) +(_lux_def Compiler + (#NamedT ["lux" "Compiler"] + (#ProdT ## "lux;info" + CompilerInfo + (#ProdT ## "lux;source" + Source + (#ProdT ## "lux;cursor" + Cursor + (#ProdT ## "lux;modules" + (#AppT List (#ProdT Text + Module)) + (#ProdT ## "lux;scopes" + (#AppT List Scope) + (#ProdT ## "lux;type-vars" + (#AppT (#AppT Bindings Nat) (#AppT Maybe Type)) + (#ProdT ## "lux;expected" + (#AppT Maybe Type) + (#ProdT ## "lux;seed" + Nat + (#ProdT ## "lux;scope-type-vars" + (#AppT List Nat) + ## "lux;host" + Void)))))))))) + (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "info") + (#Cons (#TextM "source") + (#Cons (#TextM "cursor") + (#Cons (#TextM "modules") + (#Cons (#TextM "scopes") + (#Cons (#TextM "type-vars") + (#Cons (#TextM "expected") + (#Cons (#TextM "seed") + (#Cons (#TextM "scope-type-vars") + (#Cons (#TextM "host") + #Nil)))))))))))] + (#Cons [["lux" "doc"] (#TextM "Represents the state of the Lux compiler during a run. + It's provided to macros during their invocation, so they can access compiler data. + + Caveat emptor: Avoid fiddling with it, unless you know what you're doing.")] + default-def-meta-exported))) + +## (type: (Lux a) +## (-> Compiler (Either Text [Compiler a]))) +(_lux_def Lux + (#NamedT ["lux" "Lux"] + (#UnivQ #Nil + (#LambdaT Compiler + (#AppT (#AppT Either Text) + (#ProdT Compiler (#BoundT +1)))))) + (#Cons [["lux" "doc"] (#TextM "Computations that can have access to the state of the compiler. + Those computations may also fail, or modify the state of the compiler.")] + (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "a") #;Nil))] + default-def-meta-exported))) + +## (type: Macro +## (-> (List AST) (Lux (List AST)))) +(_lux_def Macro + (#NamedT ["lux" "Macro"] + (#LambdaT ASTList (#AppT Lux ASTList))) + default-def-meta-exported) + +## Base functions & macros +## (def: _cursor +## Cursor +## ["" -1 -1]) +(_lux_def _cursor + (_lux_: Cursor ["" -1 -1]) + #Nil) + +## (def: (_meta data) +## (-> (AST' (Meta Cursor)) AST) +## [["" -1 -1] data]) +(_lux_def _meta + (_lux_: (#LambdaT (#AppT AST' + (#AppT Meta Cursor)) + AST) + (_lux_lambda _ data + [_cursor data])) + #Nil) + +## (def: (return x) +## (All [a] +## (-> a Compiler +## (Either Text [Compiler a]))) +## ...) +(_lux_def return + (_lux_: (#UnivQ #Nil + (#LambdaT (#BoundT +1) + (#LambdaT Compiler + (#AppT (#AppT Either Text) + (#ProdT Compiler + (#BoundT +1)))))) + (_lux_lambda _ val + (_lux_lambda _ state + (#Right state val)))) + #Nil) + +## (def: (fail msg) +## (All [a] +## (-> Text Compiler +## (Either Text [Compiler a]))) +## ...) +(_lux_def fail + (_lux_: (#UnivQ #Nil + (#LambdaT Text + (#LambdaT Compiler + (#AppT (#AppT Either Text) + (#ProdT Compiler + (#BoundT +1)))))) + (_lux_lambda _ msg + (_lux_lambda _ state + (#Left msg)))) + #Nil) + +(_lux_def bool$ + (_lux_: (#LambdaT Bool AST) + (_lux_lambda _ value (_meta (#BoolS value)))) + #Nil) + +(_lux_def nat$ + (_lux_: (#LambdaT Nat AST) + (_lux_lambda _ value (_meta (#NatS value)))) + #Nil) + +(_lux_def int$ + (_lux_: (#LambdaT Int AST) + (_lux_lambda _ value (_meta (#IntS value)))) + #Nil) + +(_lux_def frac$ + (_lux_: (#LambdaT Frac AST) + (_lux_lambda _ value (_meta (#FracS value)))) + #Nil) + +(_lux_def real$ + (_lux_: (#LambdaT Real AST) + (_lux_lambda _ value (_meta (#RealS value)))) + #Nil) + +(_lux_def char$ + (_lux_: (#LambdaT Char AST) + (_lux_lambda _ value (_meta (#CharS value)))) + #Nil) + +(_lux_def text$ + (_lux_: (#LambdaT Text AST) + (_lux_lambda _ text (_meta (#TextS text)))) + #Nil) + +(_lux_def symbol$ + (_lux_: (#LambdaT Ident AST) + (_lux_lambda _ ident (_meta (#SymbolS ident)))) + #Nil) + +(_lux_def tag$ + (_lux_: (#LambdaT Ident AST) + (_lux_lambda _ ident (_meta (#TagS ident)))) + #Nil) + +(_lux_def form$ + (_lux_: (#LambdaT (#AppT List AST) AST) + (_lux_lambda _ tokens (_meta (#FormS tokens)))) + #Nil) + +(_lux_def tuple$ + (_lux_: (#LambdaT (#AppT List AST) AST) + (_lux_lambda _ tokens (_meta (#TupleS tokens)))) + #Nil) + +(_lux_def record$ + (_lux_: (#LambdaT (#AppT List (#ProdT AST AST)) AST) + (_lux_lambda _ tokens (_meta (#RecordS tokens)))) + #Nil) + +(_lux_def default-macro-meta + (_lux_: Anns + (#Cons [["lux" "macro?"] (#BoolM true)] + #Nil)) + #Nil) + +(_lux_def let'' + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons lhs (#Cons rhs (#Cons body #Nil))) + (return (#Cons (form$ (#Cons (symbol$ ["" "_lux_case"]) + (#Cons rhs (#Cons lhs (#Cons body #Nil))))) + #Nil)) + + _ + (fail "Wrong syntax for let''")))) + default-macro-meta) + +(_lux_def lambda'' + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil)) + (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) + (#Cons (_meta (#SymbolS "" "")) + (#Cons arg + (#Cons (_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "lambda''")) + (#Cons (_meta (#TupleS args')) + (#Cons body #Nil)))))) + #Nil)))))) + #Nil)) + + (#Cons [_ (#SymbolS "" self)] (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil))) + (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) + (#Cons (_meta (#SymbolS "" self)) + (#Cons arg + (#Cons (_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "lambda''")) + (#Cons (_meta (#TupleS args')) + (#Cons body #Nil)))))) + #Nil)))))) + #Nil)) + + _ + (fail "Wrong syntax for lambda''")))) + default-macro-meta) + +(_lux_def export?-meta + (_lux_: AST + (tuple$ (#Cons [(tuple$ (#Cons [(text$ "lux") (#Cons [(text$ "export?") #Nil])])) + (#Cons [(form$ (#Cons [(tag$ ["lux" "BoolM"]) + (#Cons [(bool$ true) + #Nil])])) + #Nil])]))) + #Nil) + +(_lux_def hidden?-meta + (_lux_: AST + (tuple$ (#Cons [(tuple$ (#Cons [(text$ "lux") (#Cons [(text$ "hidden?") #Nil])])) + (#Cons [(form$ (#Cons [(tag$ ["lux" "BoolM"]) + (#Cons [(bool$ true) + #Nil])])) + #Nil])]))) + #Nil) + +(_lux_def macro?-meta + (_lux_: AST + (tuple$ (#Cons [(tuple$ (#Cons [(text$ "lux") (#Cons [(text$ "macro?") #Nil])])) + (#Cons [(form$ (#Cons [(tag$ ["lux" "BoolM"]) + (#Cons [(bool$ true) + #Nil])])) + #Nil])]))) + #Nil) + +(_lux_def with-export-meta + (_lux_: (#LambdaT AST AST) + (lambda'' [tail] + (form$ (#Cons (tag$ ["lux" "Cons"]) + (#Cons export?-meta + (#Cons tail #Nil)))))) + #Nil) + +(_lux_def with-hidden-meta + (_lux_: (#LambdaT AST AST) + (lambda'' [tail] + (form$ (#Cons (tag$ ["lux" "Cons"]) + (#Cons hidden?-meta + (#Cons tail #Nil)))))) + #Nil) + +(_lux_def with-macro-meta + (_lux_: (#LambdaT AST AST) + (lambda'' [tail] + (form$ (#Cons (tag$ ["lux" "Cons"]) + (#Cons macro?-meta + (#Cons tail #Nil)))))) + #Nil) + +(_lux_def def:'' + (_lux_: Macro + (lambda'' [tokens] + (_lux_case tokens + (#Cons [[_ (#TagS ["" "export"])] + (#Cons [[_ (#FormS (#Cons [name args]))] + (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + (#Cons (with-export-meta meta) #Nil)])])]))) + #Nil])) + + (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + (#Cons (with-export-meta meta) #Nil)])])]))) + #Nil])) + + (#Cons [[_ (#FormS (#Cons [name args]))] + (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + (#Cons meta #Nil)])])]))) + #Nil])) + + (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + (#Cons meta #Nil)])])]))) + #Nil])) + + _ + (fail "Wrong syntax for def''")) + )) + default-macro-meta) + +(def:'' (macro:' tokens) + default-macro-meta + Macro + (_lux_case tokens + (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil)) + (return (#Cons (form$ (#Cons (symbol$ ["lux" "def:''"]) + (#Cons (form$ (#Cons name args)) + (#Cons (with-macro-meta (tag$ ["lux" "Nil"])) + (#Cons (symbol$ ["lux" "Macro"]) + (#Cons body + #Nil))) + ))) + #Nil)) + + (#Cons [_ (#TagS ["" "export"])] (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil))) + (return (#Cons (form$ (#Cons (symbol$ ["lux" "def:''"]) + (#Cons (tag$ ["" "export"]) + (#Cons (form$ (#Cons name args)) + (#Cons (with-macro-meta (tag$ ["lux" "Nil"])) + (#Cons (symbol$ ["lux" "Macro"]) + (#Cons body + #Nil))) + )))) + #Nil)) + + (#Cons [_ (#TagS ["" "export"])] (#Cons [_ (#FormS (#Cons name args))] (#Cons meta-data (#Cons body #Nil)))) + (return (#Cons (form$ (#Cons (symbol$ ["lux" "def:''"]) + (#Cons (tag$ ["" "export"]) + (#Cons (form$ (#Cons name args)) + (#Cons (with-macro-meta meta-data) + (#Cons (symbol$ ["lux" "Macro"]) + (#Cons body + #Nil))) + )))) + #Nil)) + + _ + (fail "Wrong syntax for macro:'"))) + +(macro:' #export (comment tokens) + (#Cons [["lux" "doc"] (#TextM "## Throws away any code given to it. + ## Great for commenting out code, while retaining syntax high-lightning and formatting in your text editor. + (comment 1 2 3 4)")] + #;Nil) + (return #Nil)) + +(macro:' ($' tokens) + (_lux_case tokens + (#Cons x #Nil) + (return tokens) + + (#Cons x (#Cons y xs)) + (return (#Cons (form$ (#Cons (symbol$ ["lux" "$'"]) + (#Cons (form$ (#Cons (tag$ ["lux" "AppT"]) + (#Cons x (#Cons y #Nil)))) + xs))) + #Nil)) + + _ + (fail "Wrong syntax for $'"))) + +(def:'' (map f xs) + #Nil + (#UnivQ #Nil + (#UnivQ #Nil + (#LambdaT (#LambdaT (#BoundT +3) (#BoundT +1)) + (#LambdaT ($' List (#BoundT +3)) + ($' List (#BoundT +1)))))) + (_lux_case xs + #Nil + #Nil + + (#Cons x xs') + (#Cons (f x) (map f xs')))) + +(def:'' RepEnv + #Nil + Type + ($' List (#ProdT Text AST))) + +(def:'' (make-env xs ys) + #Nil + (#LambdaT ($' List Text) (#LambdaT ($' List AST) RepEnv)) + (_lux_case [xs ys] + [(#Cons x xs') (#Cons y ys')] + (#Cons [x y] (make-env xs' ys')) + + _ + #Nil)) + +(def:'' (Text/= x y) + #Nil + (#LambdaT Text (#LambdaT Text Bool)) + (_lux_proc ["jvm" "invokevirtual:java.lang.Object:equals:java.lang.Object"] [x y])) + +(def:'' (get-rep key env) + #Nil + (#LambdaT Text (#LambdaT RepEnv ($' Maybe AST))) + (_lux_case env + #Nil + #None + + (#Cons [k v] env') + (_lux_case (Text/= k key) + true + (#Some v) + + false + (get-rep key env')))) + +(def:'' (replace-syntax reps syntax) + #Nil + (#LambdaT RepEnv (#LambdaT AST AST)) + (_lux_case syntax + [_ (#SymbolS "" name)] + (_lux_case (get-rep name reps) + (#Some replacement) + replacement + + #None + syntax) + + [meta (#FormS parts)] + [meta (#FormS (map (replace-syntax reps) parts))] + + [meta (#TupleS members)] + [meta (#TupleS (map (replace-syntax reps) members))] + + [meta (#RecordS slots)] + [meta (#RecordS (map (_lux_: (#LambdaT (#ProdT AST AST) (#ProdT AST AST)) + (lambda'' [slot] + (_lux_case slot + [k v] + [(replace-syntax reps k) (replace-syntax reps v)]))) + slots))] + + _ + syntax) + ) + +(def:'' (update-bounds ast) + #Nil + (#LambdaT AST AST) + (_lux_case ast + [_ (#TupleS members)] + (tuple$ (map update-bounds members)) + + [_ (#RecordS pairs)] + (record$ (map (_lux_: (#LambdaT (#ProdT AST AST) (#ProdT AST AST)) + (lambda'' [pair] + (let'' [name val] pair + [name (update-bounds val)]))) + pairs)) + + [_ (#FormS (#Cons [_ (#TagS "lux" "BoundT")] (#Cons [_ (#NatS idx)] #Nil)))] + (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (nat$ (_lux_proc ["nat" "+"] [+2 idx])) #Nil))) + + [_ (#FormS members)] + (form$ (map update-bounds members)) + + _ + ast)) + +(def:'' (parse-quantified-args args next) + #Nil + ## (-> (List AST) (-> (List Text) (Lux (List AST))) (Lux (List AST))) + (#LambdaT ($' List AST) + (#LambdaT (#LambdaT ($' List Text) (#AppT Lux ($' List AST))) + (#AppT Lux ($' List AST)) + )) + (_lux_case args + #Nil + (next #Nil) + + (#Cons [_ (#SymbolS "" arg-name)] args') + (parse-quantified-args args' (lambda'' [names] (next (#Cons arg-name names)))) + + _ + (fail "Expected symbol.") + )) + +(def:'' (make-bound idx) + #Nil + (#LambdaT Nat AST) + (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (nat$ idx) #Nil)))) + +(def:'' (fold f init xs) + #Nil + ## (All [a b] (-> (-> b a a) a (List b) a)) + (#UnivQ #Nil (#UnivQ #Nil (#LambdaT (#LambdaT (#BoundT +1) + (#LambdaT (#BoundT +3) + (#BoundT +3))) + (#LambdaT (#BoundT +3) + (#LambdaT ($' List (#BoundT +1)) + (#BoundT +3)))))) + (_lux_case xs + #Nil + init + + (#Cons x xs') + (fold f (f x init) xs'))) + +(def:'' (length list) + #Nil + (#UnivQ #Nil + (#LambdaT ($' List (#BoundT +1)) Int)) + (fold (lambda'' [_ acc] (_lux_proc ["jvm" "ladd"] [1 acc])) 0 list)) + +(macro:' #export (All tokens) + (#Cons [["lux" "doc"] (#TextM "## Universal quantification. + (All [a] + (-> a a)) + + ## A name can be provided, to specify a recursive type. + (All List [a] + (| Unit + [a (List a)]))")] + #;Nil) + (let'' [self-name tokens] (_lux_case tokens + (#Cons [_ (#SymbolS "" self-name)] tokens) + [self-name tokens] + + _ + ["" tokens]) + (_lux_case tokens + (#Cons [_ (#TupleS args)] (#Cons body #Nil)) + (parse-quantified-args args + (lambda'' [names] + (let'' body' (fold (_lux_: (#LambdaT Text (#LambdaT AST AST)) + (lambda'' [name' body'] + (form$ (#Cons (tag$ ["lux" "UnivQ"]) + (#Cons (tag$ ["lux" "Nil"]) + (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil) + (update-bounds body')) #Nil)))))) + body + names) + (return (#Cons (_lux_case [(Text/= "" self-name) names] + [true _] + body' + + [_ #;Nil] + body' + + [false _] + (replace-syntax (#Cons [self-name (make-bound (_lux_proc ["nat" "*"] + [+2 (_lux_proc ["nat" "-"] + [(_lux_proc ["int" "to-nat"] + [(length names)]) + +1])]))] + #Nil) + body')) + #Nil))))) + + _ + (fail "Wrong syntax for All")) + )) + +(macro:' #export (Ex tokens) + (#Cons [["lux" "doc"] (#TextM "## Existential quantification. + (Ex [a] + [(Codec Text a) + a]) + + ## A name can be provided, to specify a recursive type. + (Ex Self [a] + [(Codec Text a) + a + (List (Self a))])")] + #;Nil) + (let'' [self-name tokens] (_lux_case tokens + (#Cons [_ (#SymbolS "" self-name)] tokens) + [self-name tokens] + + _ + ["" tokens]) + (_lux_case tokens + (#Cons [_ (#TupleS args)] (#Cons body #Nil)) + (parse-quantified-args args + (lambda'' [names] + (let'' body' (fold (_lux_: (#LambdaT Text (#LambdaT AST AST)) + (lambda'' [name' body'] + (form$ (#Cons (tag$ ["lux" "ExQ"]) + (#Cons (tag$ ["lux" "Nil"]) + (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil) + (update-bounds body')) #Nil)))))) + body + names) + (return (#Cons (_lux_case [(Text/= "" self-name) names] + [true _] + body' + + [_ #;Nil] + body' + + [false _] + (replace-syntax (#Cons [self-name (make-bound (_lux_proc ["nat" "*"] + [+2 (_lux_proc ["nat" "-"] + [(_lux_proc ["int" "to-nat"] + [(length names)]) + +1])]))] + #Nil) + body')) + #Nil))))) + + _ + (fail "Wrong syntax for Ex")) + )) + +(def:'' (reverse list) + #Nil + (All [a] (#LambdaT ($' List a) ($' List a))) + (fold (lambda'' [head tail] (#Cons head tail)) + #Nil + list)) + +(macro:' #export (-> tokens) + (#Cons [["lux" "doc"] (#TextM "## Function types: + (-> Int Int Int) + + ## This is the type of a function that takes 2 Ints and returns an Int.")] + #;Nil) + (_lux_case (reverse tokens) + (#Cons output inputs) + (return (#Cons (fold (_lux_: (#LambdaT AST (#LambdaT AST AST)) + (lambda'' [i o] (form$ (#Cons (tag$ ["lux" "LambdaT"]) (#Cons i (#Cons o #Nil)))))) + output + inputs) + #Nil)) + + _ + (fail "Wrong syntax for ->"))) + +(macro:' #export (list xs) + (#Cons [["lux" "doc"] (#TextM "## List-construction macro. + (list 1 2 3)")] + #;Nil) + (return (#Cons (fold (lambda'' [head tail] + (form$ (#Cons (tag$ ["lux" "Cons"]) + (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) + #Nil)))) + (tag$ ["lux" "Nil"]) + (reverse xs)) + #Nil))) + +(macro:' #export (list& xs) + (#Cons [["lux" "doc"] (#TextM "## List-construction macro, with the last element being a tail-list. + ## In other words, this macro prepends elements to another list. + (list& 1 2 3 (list 4 5 6))")] + #;Nil) + (_lux_case (reverse xs) + (#Cons last init) + (return (list (fold (lambda'' [head tail] + (form$ (list (tag$ ["lux" "Cons"]) + (tuple$ (list head tail))))) + last + init))) + + _ + (fail "Wrong syntax for list&"))) + +(macro:' #export (& tokens) + (#Cons [["lux" "doc"] (#TextM "## Tuple types: + (& Text Int Bool) + + ## The empty tuple, a.k.a. Unit. + (&)")] + #;Nil) + (_lux_case (reverse tokens) + #Nil + (return (list (tag$ ["lux" "UnitT"]))) + + (#Cons last prevs) + (return (list (fold (lambda'' [left right] (form$ (list (tag$ ["lux" "ProdT"]) left right))) + last + prevs))) + )) + +(macro:' #export (| tokens) + (#Cons [["lux" "doc"] (#TextM "## Variant types: + (| Text Int Bool) + + ## The empty tuple, a.k.a. Void. + (|)")] + #;Nil) + (_lux_case (reverse tokens) + #Nil + (return (list (tag$ ["lux" "VoidT"]))) + + (#Cons last prevs) + (return (list (fold (lambda'' [left right] (form$ (list (tag$ ["lux" "SumT"]) left right))) + last + prevs))) + )) + +(macro:' (lambda' tokens) + (let'' [name tokens'] (_lux_case tokens + (#Cons [[_ (#SymbolS ["" name])] tokens']) + [name tokens'] + + _ + ["" tokens]) + (_lux_case tokens' + (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])]) + (_lux_case args + #Nil + (fail "lambda' requires a non-empty arguments tuple.") + + (#Cons [harg targs]) + (return (list (form$ (list (symbol$ ["" "_lux_lambda"]) + (symbol$ ["" name]) + harg + (fold (lambda'' [arg body'] + (form$ (list (symbol$ ["" "_lux_lambda"]) + (symbol$ ["" ""]) + arg + body'))) + body + (reverse targs))))))) + + _ + (fail "Wrong syntax for lambda'")))) + +(macro:' (def:''' tokens) + (_lux_case tokens + (#Cons [[_ (#TagS ["" "export"])] + (#Cons [[_ (#FormS (#Cons [name args]))] + (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + (form$ (list (symbol$ ["lux" "lambda'"]) + name + (tuple$ args) + body)))) + (with-export-meta meta))))) + + (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + body)) + (with-export-meta meta))))) + + (#Cons [[_ (#FormS (#Cons [name args]))] + (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + (form$ (list (symbol$ ["lux" "lambda'"]) + name + (tuple$ args) + body)))) + meta)))) + + (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) type body)) + meta)))) + + _ + (fail "Wrong syntax for def'''") + )) + +(def:''' (as-pairs xs) + #Nil + (All [a] (-> ($' List a) ($' List (& a a)))) + (_lux_case xs + (#Cons x (#Cons y xs')) + (#Cons [x y] (as-pairs xs')) + + _ + #Nil)) + +(macro:' (let' tokens) + (_lux_case tokens + (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])]) + (return (list (fold (_lux_: (-> (& AST AST) AST + AST) + (lambda' [binding body] + (_lux_case binding + [label value] + (form$ (list (symbol$ ["" "_lux_case"]) value label body))))) + body + (reverse (as-pairs bindings))))) + + _ + (fail "Wrong syntax for let'"))) + +(def:''' (any? p xs) + #Nil + (All [a] + (-> (-> a Bool) ($' List a) Bool)) + (_lux_case xs + #Nil + false + + (#Cons x xs') + (_lux_case (p x) + true true + false (any? p xs')))) + +(def:''' (spliced? token) + #Nil + (-> AST Bool) + (_lux_case token + [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [_ #Nil])]))] + true + + _ + false)) + +(def:''' (wrap-meta content) + #Nil + (-> AST AST) + (tuple$ (list (tuple$ (list (text$ "") (int$ -1) (int$ -1))) + content))) + +(def:''' (untemplate-list tokens) + #Nil + (-> ($' List AST) AST) + (_lux_case tokens + #Nil + (_meta (#TagS ["lux" "Nil"])) + + (#Cons [token tokens']) + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) token (untemplate-list tokens')))))) + +(def:''' (List/append xs ys) + #Nil + (All [a] (-> ($' List a) ($' List a) ($' List a))) + (_lux_case xs + (#Cons x xs') + (#Cons x (List/append xs' ys)) + + #Nil + ys)) + +(def:''' #export (splice-helper xs ys) + (#Cons [["lux" "hidden?"] (#BoolM true)] + #;Nil) + (-> ($' List AST) ($' List AST) ($' List AST)) + (_lux_case xs + (#Cons x xs') + (#Cons x (splice-helper xs' ys)) + + #Nil + ys)) + +(macro:' #export (_$ tokens) + (#Cons [["lux" "doc"] (#TextM "## Left-association for the application of binary functions over variadic arguments. + (_$ Text/append \"Hello, \" name \".\\nHow are you?\") + + ## => + (Text/append (Text/append \"Hello, \" name) \".\\nHow are you?\")")] + #;Nil) + (_lux_case tokens + (#Cons op tokens') + (_lux_case tokens' + (#Cons first nexts) + (return (list (fold (lambda' [a1 a2] (form$ (list op a1 a2))) + first + nexts))) + + _ + (fail "Wrong syntax for _$")) + + _ + (fail "Wrong syntax for _$"))) + +(macro:' #export ($_ tokens) + (#Cons [["lux" "doc"] (#TextM "## Right-association for the application of binary functions over variadic arguments. + ($_ Text/append \"Hello, \" name \".\\nHow are you?\") + + ## => + (Text/append \"Hello, \" (Text/append name \".\\nHow are you?\"))")] + #;Nil) + (_lux_case tokens + (#Cons op tokens') + (_lux_case (reverse tokens') + (#Cons last prevs) + (return (list (fold (lambda' [a1 a2] (form$ (list op a1 a2))) + last + prevs))) + + _ + (fail "Wrong syntax for $_")) + + _ + (fail "Wrong syntax for $_"))) + +## (sig: (Monad m) +## (: (All [a] (-> a (m a))) +## wrap) +## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) +## bind)) +(def:''' Monad + (list& [["lux" "tags"] (#ListM (list (#TextM "wrap") (#TextM "bind")))] + default-def-meta-unexported) + Type + (#NamedT ["lux" "Monad"] + (All [m] + (& (All [a] (-> a ($' m a))) + (All [a b] (-> (-> a ($' m b)) + ($' m a) + ($' m b))))))) + +(def:''' Monad<Maybe> + #Nil + ($' Monad Maybe) + {#wrap + (lambda' return [x] + (#Some x)) + + #bind + (lambda' [f ma] + (_lux_case ma + #None #None + (#Some a) (f a)))}) + +(def:''' Monad<Lux> + #Nil + ($' Monad Lux) + {#wrap + (lambda' [x] + (lambda' [state] + (#Right state x))) + + #bind + (lambda' [f ma] + (lambda' [state] + (_lux_case (ma state) + (#Left msg) + (#Left msg) + + (#Right state' a) + (f a state'))))}) + +(macro:' (do tokens) + (_lux_case tokens + (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil))) + (let' [g!wrap (symbol$ ["" "wrap"]) + g!bind (symbol$ ["" " bind "]) + body' (fold (_lux_: (-> (& AST AST) AST AST) + (lambda' [binding body'] + (let' [[var value] binding] + (_lux_case var + [_ (#TagS "" "let")] + (form$ (list (symbol$ ["lux" "let'"]) value body')) + + _ + (form$ (list g!bind + (form$ (list (symbol$ ["" "_lux_lambda"]) (symbol$ ["" ""]) var body')) + value)))))) + body + (reverse (as-pairs bindings)))] + (return (list (form$ (list (symbol$ ["" "_lux_case"]) + monad + (record$ (list [(tag$ ["lux" "wrap"]) g!wrap] [(tag$ ["lux" "bind"]) g!bind])) + body'))))) + + _ + (fail "Wrong syntax for do"))) + +(def:''' (mapM m f xs) + #Nil + ## (All [m a b] + ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) + (All [m a b] + (-> ($' Monad m) + (-> a ($' m b)) + ($' List a) + ($' m ($' List b)))) + (let' [{#;wrap wrap #;bind _} m] + (_lux_case xs + #Nil + (wrap #Nil) + + (#Cons x xs') + (do m + [y (f x) + ys (mapM m f xs')] + (wrap (#Cons y ys))) + ))) + +(macro:' #export (if tokens) + (list [["lux" "doc"] (#TextM "(if true + \"Oh, yeah!\" + \"Aw hell naw!\")")]) + (_lux_case tokens + (#Cons test (#Cons then (#Cons else #Nil))) + (return (list (form$ (list (symbol$ ["" "_lux_case"]) test + (bool$ true) then + (bool$ false) else)))) + + _ + (fail "Wrong syntax for if"))) + +(def:''' (get k plist) + #Nil + (All [a] + (-> Text ($' List (& Text a)) ($' Maybe a))) + (_lux_case plist + (#Cons [[k' v] plist']) + (if (Text/= k k') + (#Some v) + (get k plist')) + + #Nil + #None)) + +(def:''' (put k v dict) + #Nil + (All [a] + (-> Text a ($' List (& Text a)) ($' List (& Text a)))) + (_lux_case dict + #Nil + (list [k v]) + + (#Cons [[k' v'] dict']) + (if (Text/= k k') + (#Cons [[k' v] dict']) + (#Cons [[k' v'] (put k v dict')])))) + +(def:''' (Text/append x y) + #Nil + (-> Text Text Text) + (_lux_proc ["jvm" "invokevirtual:java.lang.String:concat:java.lang.String"] [x y])) + +(def:''' (Ident->Text ident) + #Nil + (-> Ident Text) + (let' [[module name] ident] + (_lux_case module + "" name + _ ($_ Text/append module ";" name)))) + +(def:''' (get-meta tag def-meta) + #Nil + (-> Ident Anns ($' Maybe Ann-Value)) + (let' [[prefix name] tag] + (_lux_case def-meta + (#Cons [[prefix' name'] value] def-meta') + (_lux_case [(Text/= prefix prefix') + (Text/= name name')] + [true true] + (#Some value) + + _ + (get-meta tag def-meta')) + + #Nil + #None))) + +(def:''' (resolve-global-symbol ident state) + #Nil + (-> Ident ($' Lux Ident)) + (let' [[module name] ident + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} state] + (_lux_case (get module modules) + (#Some {#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _}) + (_lux_case (get name defs) + (#Some [def-type def-meta def-value]) + (_lux_case (get-meta ["lux" "alias"] def-meta) + (#Some (#IdentM real-name)) + (#Right [state real-name]) + + _ + (#Right [state ident])) + + #None + (#Left ($_ Text/append "Unknown definition: " (Ident->Text ident)))) + + #None + (#Left ($_ Text/append "Unknown module: " module " @ " (Ident->Text ident)))))) + +(def:''' (splice replace? untemplate tag elems) + #Nil + (-> Bool (-> AST ($' Lux AST)) AST ($' List AST) ($' Lux AST)) + (_lux_case replace? + true + (_lux_case (any? spliced? elems) + true + (do Monad<Lux> + [elems' (_lux_: ($' Lux ($' List AST)) + (mapM Monad<Lux> + (_lux_: (-> AST ($' Lux AST)) + (lambda' [elem] + (_lux_case elem + [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))] + (wrap spliced) + + _ + (do Monad<Lux> + [=elem (untemplate elem)] + (wrap (form$ (list (symbol$ ["" "_lux_:"]) + (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "AST"]))))) + (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list =elem (tag$ ["lux" "Nil"])))))))))))) + elems))] + (wrap (wrap-meta (form$ (list tag + (form$ (list& (symbol$ ["lux" "$_"]) + (symbol$ ["lux" "splice-helper"]) + elems'))))))) + + false + (do Monad<Lux> + [=elems (mapM Monad<Lux> untemplate elems)] + (wrap (wrap-meta (form$ (list tag (untemplate-list =elems))))))) + false + (do Monad<Lux> + [=elems (mapM Monad<Lux> untemplate elems)] + (wrap (wrap-meta (form$ (list tag (untemplate-list =elems)))))))) + +(def:''' (untemplate replace? subst token) + #Nil + (-> Bool Text AST ($' Lux AST)) + (_lux_case [replace? token] + [_ [_ (#BoolS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (bool$ value))))) + + [_ [_ (#NatS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "NatS"]) (nat$ value))))) + + [_ [_ (#IntS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (int$ value))))) + + [_ [_ (#FracS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "FracS"]) (frac$ value))))) + + [_ [_ (#RealS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (real$ value))))) + + [_ [_ (#CharS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (char$ value))))) + + [_ [_ (#TextS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (text$ value))))) + + [false [_ (#TagS [module name])]] + (return (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module) (text$ name))))))) + + [true [_ (#TagS [module name])]] + (let' [module' (_lux_case module + "" + subst + + _ + module)] + (return (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name)))))))) + + [true [_ (#SymbolS [module name])]] + (do Monad<Lux> + [real-name (_lux_case module + "" + (if (Text/= "" subst) + (wrap [module name]) + (resolve-global-symbol [subst name])) + + _ + (wrap [module name])) + #let [[module name] real-name]] + (return (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module) (text$ name)))))))) + + [false [_ (#SymbolS [module name])]] + (return (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module) (text$ name))))))) + + [_ [_ (#TupleS elems)]] + (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) + + [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~"])] (#Cons [unquoted #Nil])]))]] + (return unquoted) + + [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~'"])] (#Cons [keep-quoted #Nil])]))]] + (untemplate false subst keep-quoted) + + [_ [meta (#FormS elems)]] + (do Monad<Lux> + [output (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems) + #let [[_ form'] output]] + (return [meta form'])) + + [_ [_ (#RecordS fields)]] + (do Monad<Lux> + [=fields (mapM Monad<Lux> + (_lux_: (-> (& AST AST) ($' Lux AST)) + (lambda' [kv] + (let' [[k v] kv] + (do Monad<Lux> + [=k (untemplate replace? subst k) + =v (untemplate replace? subst v)] + (wrap (tuple$ (list =k =v))))))) + fields)] + (wrap (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) (untemplate-list =fields)))))) + )) + +(macro:' #export (host tokens) + (list [["lux" "doc"] (#TextM "## Macro to treat host-types as Lux-types. + (host java.lang.Object) + + (host java.util.List [java.lang.Long])")]) + (_lux_case tokens + (#Cons [_ (#SymbolS "" class-name)] #Nil) + (return (list (form$ (list (tag$ ["lux" "HostT"]) (text$ class-name) (tag$ ["lux" "Nil"]))))) + + (#Cons [_ (#SymbolS "" class-name)] (#Cons [_ (#TupleS params)] #Nil)) + (return (list (form$ (list (tag$ ["lux" "HostT"]) (text$ class-name) (untemplate-list params))))) + + _ + (fail "Wrong syntax for host"))) + +(def:'' (current-module-name state) + #Nil + ($' Lux Text) + (_lux_case state + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} + (_lux_case (reverse scopes) + (#Cons {#name (#;Cons module-name #Nil) #inner-closures _ #locals _ #closure _} _) + (#Right [state module-name]) + + _ + (#Left "Can't get the module name without a module!") + ))) + +(macro:' #export (` tokens) + (list [["lux" "doc"] (#TextM "## Hygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~@) must also be used as forms. + ## All unprefixed macros will receive their parent module's prefix if imported; otherwise will receive the prefix of the module on which the quasi-quote is being used. + (` (def: (~ name) + (lambda [(~@ args)] + (~ body))))")]) + (_lux_case tokens + (#Cons template #Nil) + (do Monad<Lux> + [current-module current-module-name + =template (untemplate true current-module template)] + (wrap (list (form$ (list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) + + _ + (fail "Wrong syntax for `"))) + +(macro:' #export (`' tokens) + (list [["lux" "doc"] (#TextM "## Unhygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~@) must also be used as forms. + (`' (def: (~ name) + (lambda [(~@ args)] + (~ body))))")]) + (_lux_case tokens + (#Cons template #Nil) + (do Monad<Lux> + [=template (untemplate true "" template)] + (wrap (list (form$ (list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) + + _ + (fail "Wrong syntax for `"))) + +(macro:' #export (' tokens) + (list [["lux" "doc"] (#TextM "## Quotation as a macro. + (' \"YOLO\")")]) + (_lux_case tokens + (#Cons template #Nil) + (do Monad<Lux> + [=template (untemplate false "" template)] + (wrap (list (form$ (list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) + + _ + (fail "Wrong syntax for '"))) + +(macro:' #export (|> tokens) + (list [["lux" "doc"] (#TextM "## Piping macro. + (|> elems (map ->Text) (interpose \" \") (fold Text/append \"\")) + + ## => + (fold Text/append \"\" + (interpose \" \" + (map ->Text elems)))")]) + (_lux_case tokens + (#Cons [init apps]) + (return (list (fold (_lux_: (-> AST AST AST) + (lambda' [app acc] + (_lux_case app + [_ (#TupleS parts)] + (tuple$ (List/append parts (list acc))) + + [_ (#FormS parts)] + (form$ (List/append parts (list acc))) + + _ + (` ((~ app) (~ acc)))))) + init + apps))) + + _ + (fail "Wrong syntax for |>"))) + +(macro:' #export (<| tokens) + (list [["lux" "doc"] (#TextM "## Reverse piping macro. + (<| (fold Text/append \"\") (interpose \" \") (map ->Text) elems) + + ## => + (fold Text/append \"\" + (interpose \" \" + (map ->Text elems)))")]) + (_lux_case (reverse tokens) + (#Cons [init apps]) + (return (list (fold (_lux_: (-> AST AST AST) + (lambda' [app acc] + (_lux_case app + [_ (#TupleS parts)] + (tuple$ (List/append parts (list acc))) + + [_ (#FormS parts)] + (form$ (List/append parts (list acc))) + + _ + (` ((~ app) (~ acc)))))) + init + apps))) + + _ + (fail "Wrong syntax for <|"))) + +(def:''' #export (. f g) + (list [["lux" "doc"] (#TextM "Function composition.")]) + (All [a b c] + (-> (-> b c) (-> a b) (-> a c))) + (lambda' [x] (f (g x)))) + +(def:''' (get-ident x) + #Nil + (-> AST ($' Maybe Ident)) + (_lux_case x + [_ (#SymbolS sname)] + (#Some sname) + + _ + #None)) + +(def:''' (get-tag x) + #Nil + (-> AST ($' Maybe Ident)) + (_lux_case x + [_ (#TagS sname)] + (#Some sname) + + _ + #None)) + +(def:''' (get-name x) + #Nil + (-> AST ($' Maybe Text)) + (_lux_case x + [_ (#SymbolS "" sname)] + (#Some sname) + + _ + #None)) + +(def:''' (tuple->list tuple) + #Nil + (-> AST ($' Maybe ($' List AST))) + (_lux_case tuple + [_ (#TupleS members)] + (#Some members) + + _ + #None)) + +(def:''' (apply-template env template) + #Nil + (-> RepEnv AST AST) + (_lux_case template + [_ (#SymbolS "" sname)] + (_lux_case (get-rep sname env) + (#Some subst) + subst + + _ + template) + + [meta (#TupleS elems)] + [meta (#TupleS (map (apply-template env) elems))] + + [meta (#FormS elems)] + [meta (#FormS (map (apply-template env) elems))] + + [meta (#RecordS members)] + [meta (#RecordS (map (_lux_: (-> (& AST AST) (& AST AST)) + (lambda' [kv] + (let' [[slot value] kv] + [(apply-template env slot) (apply-template env value)]))) + members))] + + _ + template)) + +(def:''' (join-map f xs) + #Nil + (All [a b] + (-> (-> a ($' List b)) ($' List a) ($' List b))) + (_lux_case xs + #Nil + #Nil + + (#Cons [x xs']) + (List/append (f x) (join-map f xs')))) + +(def:''' (every? p xs) + #Nil + (All [a] + (-> (-> a Bool) ($' List a) Bool)) + (fold (lambda' [_2 _1] (if _1 (p _2) false)) true xs)) + +(def:''' (i= x y) + #Nil + (-> Int Int Bool) + (_lux_proc ["jvm" "leq"] [x y])) + +(def:''' (n= x y) + #Nil + (-> Nat Nat Bool) + (_lux_proc ["nat" "="] [x y])) + +(def:''' (->Text x) + #Nil + (-> (host java.lang.Object) Text) + (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x])) + +(macro:' #export (do-template tokens) + (list [["lux" "doc"] (#TextM "## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary. + (do-template [<name> <diff>] + [(def: #export <name> + (-> Int Int) + (+ <diff>))] + + [inc 1] + [dec -1])")]) + (_lux_case tokens + (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])]) + (_lux_case [(mapM Monad<Maybe> get-name bindings) + (mapM Monad<Maybe> tuple->list data)] + [(#Some bindings') (#Some data')] + (let' [apply (_lux_: (-> RepEnv ($' List AST)) + (lambda' [env] (map (apply-template env) templates))) + num-bindings (length bindings')] + (if (every? (i= num-bindings) (map length data')) + (|> data' + (join-map (. apply (make-env bindings'))) + return) + (fail (Text/append "Irregular arguments vectors for do-template. Expected size " (->Text num-bindings))))) + + _ + (fail "Wrong syntax for do-template")) + + _ + (fail "Wrong syntax for do-template"))) + + +(do-template [<name> <cmp> <type>] + [(def:''' (<name> x y) + #Nil + (-> <type> <type> Bool) + (_lux_proc ["jvm" <cmp>] [x y]))] + + ## [i= "leq" Int] + [i> "lgt" Int] + [i< "llt" Int] + ) + +(do-template [<name> <cmp> <eq> <type>] + [(def:''' (<name> x y) + #Nil + (-> <type> <type> Bool) + (if (<cmp> x y) + true + (<eq> x y)))] + + [i>= i> i= Int] + [i<= i< i= Int] + ) + +(do-template [<name> <op> <type>] + [(def:''' (<name> x y) + #Nil + (-> <type> <type> <type>) + (_lux_proc <op> [x y]))] + + [i+ ["jvm" "ladd"] Int] + [i- ["jvm" "lsub"] Int] + [i* ["jvm" "lmul"] Int] + [i/ ["jvm" "ldiv"] Int] + [i% ["jvm" "lrem"] Int] + + [n+ ["nat" "+"] Nat] + [n- ["nat" "-"] Nat] + [n* ["nat" "*"] Nat] + [n/ ["nat" "/"] Nat] + [n% ["nat" "%"] Nat] + ) + +(def:''' (multiple? div n) + #Nil + (-> Int Int Bool) + (i= 0 (i% n div))) + +(def:''' #export (not x) + #Nil + (-> Bool Bool) + (if x false true)) + +(def:''' (find-macro' modules current-module module name) + #Nil + (-> ($' List (& Text Module)) + Text Text Text + ($' Maybe Macro)) + (do Monad<Maybe> + [$module (get module modules) + gdef (let' [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _} (_lux_: Module $module)] + (get name bindings))] + (let' [[def-type def-meta def-value] (_lux_: Def gdef)] + (_lux_case (get-meta ["lux" "macro?"] def-meta) + (#Some (#BoolM true)) + (_lux_case (get-meta ["lux" "export?"] def-meta) + (#Some (#BoolM true)) + (#Some (_lux_:! Macro def-value)) + + _ + (if (Text/= module current-module) + (#Some (_lux_:! Macro def-value)) + #None)) + + _ + (_lux_case (get-meta ["lux" "alias"] def-meta) + (#Some (#IdentM [r-module r-name])) + (find-macro' modules current-module r-module r-name) + + _ + #None) + )) + )) + +(def:''' (normalize ident) + #Nil + (-> Ident ($' Lux Ident)) + (_lux_case ident + ["" name] + (do Monad<Lux> + [module-name current-module-name] + (wrap [module-name name])) + + _ + (return ident))) + +(def:''' (find-macro ident) + #Nil + (-> Ident ($' Lux ($' Maybe Macro))) + (do Monad<Lux> + [current-module current-module-name] + (let' [[module name] ident] + (lambda' [state] + (_lux_case state + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected + #cursor cursor + #scope-type-vars scope-type-vars} + (#Right state (find-macro' modules current-module module name))))))) + +(def:''' (macro? ident) + #Nil + (-> Ident ($' Lux Bool)) + (do Monad<Lux> + [ident (normalize ident) + output (find-macro ident)] + (wrap (_lux_case output + (#Some _) true + #None false)))) + +(def:''' (List/join xs) + #Nil + (All [a] + (-> ($' List ($' List a)) ($' List a))) + (fold List/append #Nil (reverse xs))) + +(def:''' (interpose sep xs) + #Nil + (All [a] + (-> a ($' List a) ($' List a))) + (_lux_case xs + #Nil + xs + + (#Cons [x #Nil]) + xs + + (#Cons [x xs']) + (list& x sep (interpose sep xs')))) + +(def:''' (macro-expand-once token) + #Nil + (-> AST ($' Lux ($' List AST))) + (_lux_case token + [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))] + (do Monad<Lux> + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) + (macro args) + + #None + (return (list token)))) + + _ + (return (list token)))) + +(def:''' (macro-expand token) + #Nil + (-> AST ($' Lux ($' List AST))) + (_lux_case token + [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))] + (do Monad<Lux> + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) + (do Monad<Lux> + [expansion (macro args) + expansion' (mapM Monad<Lux> macro-expand expansion)] + (wrap (List/join expansion'))) + + #None + (return (list token)))) + + _ + (return (list token)))) + +(def:''' (macro-expand-all syntax) + #Nil + (-> AST ($' Lux ($' List AST))) + (_lux_case syntax + [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))] + (do Monad<Lux> + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) + (do Monad<Lux> + [expansion (macro args) + expansion' (mapM Monad<Lux> macro-expand-all expansion)] + (wrap (List/join expansion'))) + + #None + (do Monad<Lux> + [args' (mapM Monad<Lux> macro-expand-all args)] + (wrap (list (form$ (#Cons (symbol$ macro-name) (List/join args')))))))) + + [_ (#FormS members)] + (do Monad<Lux> + [members' (mapM Monad<Lux> macro-expand-all members)] + (wrap (list (form$ (List/join members'))))) + + [_ (#TupleS members)] + (do Monad<Lux> + [members' (mapM Monad<Lux> macro-expand-all members)] + (wrap (list (tuple$ (List/join members'))))) + + [_ (#RecordS pairs)] + (do Monad<Lux> + [pairs' (mapM Monad<Lux> + (lambda' [kv] + (let' [[key val] kv] + (do Monad<Lux> + [val' (macro-expand-all val)] + (_lux_case val' + (#;Cons val'' #;Nil) + (return [key val'']) + + _ + (fail "The value-part of a KV-pair in a record must macro-expand to a single AST."))))) + pairs)] + (wrap (list (record$ pairs')))) + + _ + (return (list syntax)))) + +(def:''' (walk-type type) + #Nil + (-> AST AST) + (_lux_case type + [_ (#FormS (#Cons [_ (#TagS tag)] parts))] + (form$ (#Cons [(tag$ tag) (map walk-type parts)])) + + [_ (#TupleS members)] + (` (& (~@ (map walk-type members)))) + + [_ (#FormS (#Cons type-fn args))] + (fold (_lux_: (-> AST AST AST) + (lambda' [arg type-fn] (` (#;AppT (~ type-fn) (~ arg))))) + (walk-type type-fn) + (map walk-type args)) + + _ + type)) + +(macro:' #export (type tokens) + (list [["lux" "doc"] (#TextM "## Takes a type expression and returns it's representation as data-structure. + (type (All [a] (Maybe (List a))))")]) + (_lux_case tokens + (#Cons type #Nil) + (do Monad<Lux> + [type+ (macro-expand-all type)] + (_lux_case type+ + (#Cons type' #Nil) + (wrap (list (walk-type type'))) + + _ + (fail "The expansion of the type-syntax had to yield a single element."))) + + _ + (fail "Wrong syntax for type"))) + +(macro:' #export (: tokens) + (list [["lux" "doc"] (#TextM "## The type-annotation macro. + (: (List Int) (list 1 2 3))")]) + (_lux_case tokens + (#Cons type (#Cons value #Nil)) + (return (list (` (;_lux_: (type (~ type)) (~ value))))) + + _ + (fail "Wrong syntax for :"))) + +(macro:' #export (:! tokens) + (list [["lux" "doc"] (#TextM "## The type-coercion macro. + (:! Dinosaur (list 1 2 3))")]) + (_lux_case tokens + (#Cons type (#Cons value #Nil)) + (return (list (` (;_lux_:! (type (~ type)) (~ value))))) + + _ + (fail "Wrong syntax for :!"))) + +(def:''' (empty? xs) + #Nil + (All [a] (-> ($' List a) Bool)) + (_lux_case xs + #Nil true + _ false)) + +(do-template [<name> <type> <value>] + [(def:''' (<name> xy) + #Nil + (All [a b] (-> (& a b) <type>)) + (let' [[x y] xy] <value>))] + + [first a x] + [second b y]) + +(def:''' (unfold-type-def type-asts) + #Nil + (-> ($' List AST) ($' Lux (& AST ($' Maybe ($' List Text))))) + (_lux_case type-asts + (#Cons [_ (#RecordS pairs)] #;Nil) + (do Monad<Lux> + [members (mapM Monad<Lux> + (: (-> [AST AST] (Lux [Text AST])) + (lambda' [pair] + (_lux_case pair + [[_ (#TagS "" member-name)] member-type] + (return [member-name member-type]) + + _ + (fail "Wrong syntax for variant case.")))) + pairs)] + (return [(` (& (~@ (map second members)))) + (#Some (map first members))])) + + (#Cons type #Nil) + (_lux_case type + [_ (#TagS "" member-name)] + (return [(` #;UnitT) (#;Some (list member-name))]) + + [_ (#FormS (#Cons [_ (#TagS "" member-name)] member-types))] + (return [(` (& (~@ member-types))) (#;Some (list member-name))]) + + _ + (return [type #None])) + + (#Cons case cases) + (do Monad<Lux> + [members (mapM Monad<Lux> + (: (-> AST (Lux [Text AST])) + (lambda' [case] + (_lux_case case + [_ (#TagS "" member-name)] + (return [member-name (` Unit)]) + + [_ (#FormS (#Cons [_ (#TagS "" member-name)] (#Cons member-type #Nil)))] + (return [member-name member-type]) + + [_ (#FormS (#Cons [_ (#TagS "" member-name)] member-types))] + (return [member-name (` (& (~@ member-types)))]) + + _ + (fail "Wrong syntax for variant case.")))) + (list& case cases))] + (return [(` (| (~@ (map second members)))) + (#Some (map first members))])) + + _ + (fail "Improper type-definition syntax"))) + +(def:''' (gensym prefix state) + #Nil + (-> Text ($' Lux AST)) + (_lux_case state + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected + #cursor cursor + #scope-type-vars scope-type-vars} + (#Right {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed (n+ +1 seed) #expected expected + #cursor cursor + #scope-type-vars scope-type-vars} + (symbol$ ["" ($_ Text/append "__gensym__" prefix (->Text seed))])))) + +(macro:' #export (Rec tokens) + (list [["lux" "doc"] (#TextM "## Parameter-less recursive types. + ## A name has to be given to the whole type, to use it within it's body. + (Rec Self + [Int (List Self)])")]) + (_lux_case tokens + (#Cons [_ (#SymbolS "" name)] (#Cons body #Nil)) + (let' [body' (replace-syntax (list [name (` (#AppT (~ (make-bound +0)) (~ (make-bound +1))))]) body)] + (return (list (` (#AppT (#UnivQ #Nil (~ body')) Void))))) + + _ + (fail "Wrong syntax for Rec"))) + +(macro:' #export (exec tokens) + (list [["lux" "doc"] (#TextM "## Sequential execution of expressions (great for side-effects). + (exec + (log! \"#1\") + (log! \"#2\") + (log! \"#3\") + \"YOLO\")")]) + (_lux_case (reverse tokens) + (#Cons value actions) + (let' [dummy (symbol$ ["" ""])] + (return (list (fold (_lux_: (-> AST AST AST) + (lambda' [pre post] (` (;_lux_case (~ pre) (~ dummy) (~ post))))) + value + actions)))) + + _ + (fail "Wrong syntax for exec"))) + +(macro:' (def:' tokens) + (let' [[export? tokens'] (_lux_case tokens + (#Cons [_ (#TagS "" "export")] tokens') + [true tokens'] + + _ + [false tokens]) + parts (: (Maybe [AST (List AST) (Maybe AST) AST]) + (_lux_case tokens' + (#Cons [_ (#FormS (#Cons name args))] (#Cons type (#Cons body #Nil))) + (#Some name args (#Some type) body) + + (#Cons name (#Cons type (#Cons body #Nil))) + (#Some name #Nil (#Some type) body) + + (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil)) + (#Some name args #None body) + + (#Cons name (#Cons body #Nil)) + (#Some name #Nil #None body) + + _ + #None))] + (_lux_case parts + (#Some name args ?type body) + (let' [body' (_lux_case args + #Nil + body + + _ + (` (lambda' (~ name) [(~@ args)] (~ body)))) + body'' (_lux_case ?type + (#Some type) + (` (: (~ type) (~ body'))) + + #None + body')] + (return (list (` (;_lux_def (~ name) (~ body'') + (~ (if export? + (with-export-meta (tag$ ["lux" "Nil"])) + (tag$ ["lux" "Nil"])))))))) + + #None + (fail "Wrong syntax for def'")))) + +(def:' (rejoin-pair pair) + (-> [AST AST] (List AST)) + (let' [[left right] pair] + (list left right))) + +(def:''' (Nat->Text x) + #Nil + (-> Nat Text) + (_lux_proc ["nat" "encode"] [x])) + +(def:''' (Frac->Text x) + #Nil + (-> Frac Text) + (_lux_proc ["frac" "encode"] [x])) + +(def:' (ast-to-text ast) + (-> AST Text) + (_lux_case ast + [_ (#BoolS value)] + (->Text value) + + [_ (#NatS value)] + (Nat->Text value) + + [_ (#IntS value)] + (->Text value) + + [_ (#FracS value)] + (Frac->Text value) + + [_ (#RealS value)] + (->Text value) + + [_ (#CharS value)] + ($_ Text/append "#" "\"" (->Text value) "\"") + + [_ (#TextS value)] + ($_ Text/append "\"" value "\"") + + [_ (#SymbolS [prefix name])] + (if (Text/= "" prefix) + name + ($_ Text/append prefix ";" name)) + + [_ (#TagS [prefix name])] + (if (Text/= "" prefix) + ($_ Text/append "#" name) + ($_ Text/append "#" prefix ";" name)) + + [_ (#FormS xs)] + ($_ Text/append "(" (|> xs + (map ast-to-text) + (interpose " ") + reverse + (fold Text/append "")) ")") + + [_ (#TupleS xs)] + ($_ Text/append "[" (|> xs + (map ast-to-text) + (interpose " ") + reverse + (fold Text/append "")) "]") + + [_ (#RecordS kvs)] + ($_ Text/append "{" (|> kvs + (map (lambda' [kv] (_lux_case kv [k v] ($_ Text/append (ast-to-text k) " " (ast-to-text v))))) + (interpose " ") + reverse + (fold Text/append "")) "}") + )) + +(def:' (expander branches) + (-> (List AST) (Lux (List AST))) + (_lux_case branches + (#;Cons [_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))] + (#;Cons body + branches')) + (do Monad<Lux> + [??? (macro? macro-name)] + (if ??? + (do Monad<Lux> + [init-expansion (macro-expand-once (form$ (list& (symbol$ macro-name) (form$ macro-args) body branches')))] + (expander init-expansion)) + (do Monad<Lux> + [sub-expansion (expander branches')] + (wrap (list& (form$ (list& (symbol$ macro-name) macro-args)) + body + sub-expansion))))) + + (#;Cons pattern (#;Cons body branches')) + (do Monad<Lux> + [sub-expansion (expander branches')] + (wrap (list& pattern body sub-expansion))) + + #;Nil + (do Monad<Lux> [] (wrap (list))) + + _ + (fail ($_ Text/append "\"lux;case\" expects an even number of tokens: " (|> branches + (map ast-to-text) + (interpose " ") + reverse + (fold Text/append "")))))) + +(macro:' #export (case tokens) + (list [["lux" "doc"] (#TextM "## The pattern-matching macro. + ## Allows the usage of macros within the patterns to provide custom syntax. + (case (: (List Int) (list 1 2 3)) + (#Cons x (#Cons y (#Cons z #Nil))) + (#Some ($_ * x y z)) + + _ + #None)")]) + (_lux_case tokens + (#Cons value branches) + (do Monad<Lux> + [expansion (expander branches)] + (wrap (list (` (;_lux_case (~ value) (~@ expansion)))))) + + _ + (fail "Wrong syntax for case"))) + +(macro:' #export (^ tokens) + (list [["lux" "doc"] (#TextM "## Macro-expanding patterns. + ## It's a special macro meant to be used with case. + (case (: (List Int) (list 1 2 3)) + (^ (list x y z)) + (#Some ($_ * x y z)) + + _ + #None)")]) + (case tokens + (#Cons [_ (#FormS (#Cons pattern #Nil))] (#Cons body branches)) + (do Monad<Lux> + [pattern+ (macro-expand-all pattern)] + (case pattern+ + (#Cons pattern' #Nil) + (wrap (list& pattern' body branches)) + + _ + (fail "^ can only expand to 1 pattern."))) + + _ + (fail "Wrong syntax for ^ macro"))) + +(macro:' #export (^or tokens) + (list [["lux" "doc"] (#TextM "## Or-patterns. + ## It's a special macro meant to be used with case. + (type: Weekday + (| #Monday + #Tuesday + #Wednesday + #Thursday + #Friday + #Saturday + #Sunday)) + + (def: (weekend? day) + (-> Weekday Bool) + (case day + (^or #Saturday #Sunday) + true + + _ + false))")]) + (case tokens + (^ (list& [_ (#FormS patterns)] body branches)) + (case patterns + #Nil + (fail "^or can't have 0 patterns") + + _ + (let' [pairs (|> patterns + (map (lambda' [pattern] (list pattern body))) + (List/join))] + (return (List/append pairs branches)))) + _ + (fail "Wrong syntax for ^or"))) + +(def:' (symbol? ast) + (-> AST Bool) + (case ast + [_ (#SymbolS _)] + true + + _ + false)) + +(macro:' #export (let tokens) + (list [["lux" "doc"] (#TextM "## Creates local bindings. + ## Can (optionally) use pattern-matching macros when binding. + (let [x (foo bar) + y (baz quux)] + (op x y))")]) + (case tokens + (^ (list [_ (#TupleS bindings)] body)) + (if (multiple? 2 (length bindings)) + (|> bindings as-pairs reverse + (fold (: (-> [AST AST] AST AST) + (lambda' [lr body'] + (let' [[l r] lr] + (if (symbol? l) + (` (;_lux_case (~ r) (~ l) (~ body'))) + (` (case (~ r) (~ l) (~ body'))))))) + body) + list + return) + (fail "let requires an even number of parts")) + + _ + (fail "Wrong syntax for let"))) + +(macro:' #export (lambda tokens) + (list [["lux" "doc"] (#TextM "## Syntax for creating functions. + ## Allows for giving the function itself a name, for the sake of recursion. + (: (All [a b] (-> a b a)) + (lambda [x y] x)) + + (: (All [a b] (-> a b a)) + (lambda const [x y] x))")]) + (case (: (Maybe [Ident AST (List AST) AST]) + (case tokens + (^ (list [_ (#TupleS (#Cons head tail))] body)) + (#Some ["" ""] head tail body) + + (^ (list [_ (#SymbolS ["" name])] [_ (#TupleS (#Cons head tail))] body)) + (#Some ["" name] head tail body) + + _ + #None)) + (#Some ident head tail body) + (let [g!blank (symbol$ ["" ""]) + g!name (symbol$ ident) + body+ (fold (: (-> AST AST AST) + (lambda' [arg body'] + (if (symbol? arg) + (` (;_lux_lambda (~ g!blank) (~ arg) (~ body'))) + (` (;_lux_lambda (~ g!blank) (~ g!blank) + (case (~ g!blank) (~ arg) (~ body'))))))) + body + (reverse tail))] + (return (list (if (symbol? head) + (` (;_lux_lambda (~ g!name) (~ head) (~ body+))) + (` (;_lux_lambda (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) + + #None + (fail "Wrong syntax for lambda"))) + +(def:' (process-def-meta-value ast) + (-> AST (Lux AST)) + (case ast + [_ (#BoolS value)] + (return (form$ (list (tag$ ["lux" "BoolM"]) (bool$ value)))) + + [_ (#NatS value)] + (return (form$ (list (tag$ ["lux" "NatM"]) (nat$ value)))) + + [_ (#IntS value)] + (return (form$ (list (tag$ ["lux" "IntM"]) (int$ value)))) + + [_ (#FracS value)] + (return (form$ (list (tag$ ["lux" "FracM"]) (frac$ value)))) + + [_ (#RealS value)] + (return (form$ (list (tag$ ["lux" "RealM"]) (real$ value)))) + + [_ (#CharS value)] + (return (form$ (list (tag$ ["lux" "CharM"]) (char$ value)))) + + [_ (#TextS value)] + (return (form$ (list (tag$ ["lux" "TextM"]) (text$ value)))) + + [_ (#TagS [prefix name])] + (return (form$ (list (tag$ ["lux" "IdentM"]) (tuple$ (list (text$ prefix) (text$ name)))))) + + (^or [_ (#FormS _)] [_ (#SymbolS _)]) + (return ast) + + [_ (#TupleS xs)] + (do Monad<Lux> + [=xs (mapM Monad<Lux> process-def-meta-value xs)] + (wrap (form$ (list (tag$ ["lux" "ListM"]) (untemplate-list =xs))))) + + [_ (#RecordS kvs)] + (do Monad<Lux> + [=xs (mapM Monad<Lux> + (: (-> [AST AST] (Lux AST)) + (lambda [[k v]] + (case k + [_ (#TextS =k)] + (do Monad<Lux> + [=v (process-def-meta-value v)] + (wrap (tuple$ (list (text$ =k) =v)))) + + _ + (fail (Text/append "Wrong syntax for DictM key: " (ast-to-text k)))))) + kvs)] + (wrap (form$ (list (tag$ ["lux" "DictM"]) (untemplate-list =xs))))) + )) + +(def:' (process-def-meta ast) + (-> AST (Lux AST)) + (case ast + [_ (#RecordS kvs)] + (do Monad<Lux> + [=kvs (mapM Monad<Lux> + (: (-> [AST AST] (Lux AST)) + (lambda [[k v]] + (case k + [_ (#TagS [pk nk])] + (do Monad<Lux> + [=v (process-def-meta-value v)] + (wrap (tuple$ (list (tuple$ (list (text$ pk) (text$ nk))) + =v)))) + + _ + (fail (Text/append "Wrong syntax for Anns: " (ast-to-text ast)))))) + kvs)] + (wrap (untemplate-list =kvs))) + + _ + (fail (Text/append "Wrong syntax for Anns: " (ast-to-text ast))))) + +(def:' (with-func-args args meta) + (-> (List AST) AST AST) + (case args + #;Nil + meta + + _ + (` (#;Cons [["lux" "func-args"] + (#;ListM (list (~@ (map (lambda [arg] + (` (#;TextM (~ (text$ (ast-to-text arg)))))) + args))))] + (~ meta))))) + +(def:' (with-type-args args) + (-> (List AST) AST) + (` {#;type-args (#;ListM (list (~@ (map (lambda [arg] + (` (#;TextM (~ (text$ (ast-to-text arg)))))) + args))))})) + +(def:' Export-Level + Type + ($' Either + Unit ## Exported + Unit ## Hidden + )) + +(def:' (export-level^ tokens) + (-> (List AST) [(Maybe Export-Level) (List AST)]) + (case tokens + (#Cons [_ (#TagS [_ "export"])] tokens') + [(#;Some (#;Left [])) tokens'] + + (#Cons [_ (#TagS [_ "hidden"])] tokens') + [(#;Some (#;Right [])) tokens'] + + _ + [#;None tokens])) + +(def:' (export-level ?el) + (-> (Maybe Export-Level) (List AST)) + (case ?el + #;None + (list) + + (#;Some (#;Left [])) + (list (' #export)) + + (#;Some (#;Right [])) + (list (' #hidden)))) + +(macro:' #export (def: tokens) + (list [["lux" "doc"] (#TextM "## Defines global constants/functions. + (def: (rejoin-pair pair) + (-> [AST AST] (List AST)) + (let [[left right] pair] + (list left right))) + + (def: branching-exponent + Int + 5)")]) + (let [[export? tokens'] (export-level^ tokens) + parts (: (Maybe [AST (List AST) (Maybe AST) AST AST]) + (case tokens' + (^ (list [_ (#FormS (#Cons name args))] meta type body)) + (#Some name args (#Some type) body meta) + + (^ (list name meta type body)) + (#Some name #Nil (#Some type) body meta) + + (^ (list [_ (#FormS (#Cons name args))] type body)) + (#Some name args (#Some type) body (' {})) + + (^ (list name type body)) + (#Some name #Nil (#Some type) body (' {})) + + (^ (list [_ (#FormS (#Cons name args))] body)) + (#Some name args #None body (' {})) + + (^ (list name body)) + (#Some name #Nil #None body (' {})) + + _ + #None))] + (case parts + (#Some name args ?type body meta) + (let [body (case args + #Nil + body + + _ + (` (lambda (~ name) [(~@ args)] (~ body)))) + body (case ?type + (#Some type) + (` (: (~ type) (~ body))) + + #None + body)] + (do Monad<Lux> + [=meta (process-def-meta meta)] + (return (list (` (;_lux_def (~ name) (~ body) (~ (with-func-args args + (case export? + #;None + =meta + + (#;Some (#;Left [])) + (with-export-meta =meta) + + (#;Some (#;Right [])) + (|> =meta + with-export-meta + with-hidden-meta) + ))))))))) + + #None + (fail "Wrong syntax for def")))) + +(def: (meta-ast-add addition meta) + (-> [AST AST] AST AST) + (case [addition meta] + [[name value] [cursor (#;RecordS pairs)]] + [cursor (#;RecordS (#;Cons [name value] pairs))] + + _ + meta)) + +(def: (meta-ast-merge addition base) + (-> AST AST AST) + (case addition + [cursor (#;RecordS pairs)] + (fold meta-ast-add base pairs) + + _ + base)) + +(macro:' #export (macro: tokens) + (list [["lux" "doc"] (#TextM "(macro: #export (ident-for tokens) + (case tokens + (^template [<tag>] + (^ (list [_ (<tag> [prefix name])])) + (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))) + ([#;SymbolS] [#;TagS]) + + _ + (fail \"Wrong syntax for ident-for\")))")]) + (let [[exported? tokens] (export-level^ tokens) + name+args+meta+body?? (: (Maybe [Ident (List AST) AST AST]) + (case tokens + (^ (list [_ (#;FormS (list& [_ (#SymbolS name)] args))] body)) + (#Some [name args (` {}) body]) + + (^ (list [_ (#;SymbolS name)] body)) + (#Some [name #Nil (` {}) body]) + + (^ (list [_ (#;FormS (list& [_ (#SymbolS name)] args))] [meta-rec-cursor (#;RecordS meta-rec-parts)] body)) + (#Some [name args [meta-rec-cursor (#;RecordS meta-rec-parts)] body]) + + (^ (list [_ (#;SymbolS name)] [meta-rec-cursor (#;RecordS meta-rec-parts)] body)) + (#Some [name #Nil [meta-rec-cursor (#;RecordS meta-rec-parts)] body]) + + _ + #None))] + (case name+args+meta+body?? + (#Some [name args meta body]) + (let [name (symbol$ name) + def-sig (case args + #;Nil name + _ (` ((~ name) (~@ args))))] + (return (list (` (;;def: (~@ (export-level exported?)) + (~ def-sig) + (~ (meta-ast-merge (` {#;macro? true}) + meta)) + + ;;Macro + (~ body)))))) + + + #None + (fail "Wrong syntax for macro:")))) + +(macro: #export (sig: tokens) + {#;doc "## Definition of signatures ala ML. + (sig: #export (Ord a) + (: (Eq a) + eq) + (: (-> a a Bool) + <) + (: (-> a a Bool) + <=) + (: (-> a a Bool) + >) + (: (-> a a Bool) + >=))"} + (let [[exported? tokens'] (export-level^ tokens) + ?parts (: (Maybe [Ident (List AST) AST (List AST)]) + (case tokens' + (^ (list& [_ (#FormS (list& [_ (#SymbolS name)] args))] [meta-rec-cursor (#;RecordS meta-rec-parts)] sigs)) + (#Some name args [meta-rec-cursor (#;RecordS meta-rec-parts)] sigs) + + (^ (list& [_ (#SymbolS name)] [meta-rec-cursor (#;RecordS meta-rec-parts)] sigs)) + (#Some name #Nil [meta-rec-cursor (#;RecordS meta-rec-parts)] sigs) + + (^ (list& [_ (#FormS (list& [_ (#SymbolS name)] args))] sigs)) + (#Some name args (` {}) sigs) + + (^ (list& [_ (#SymbolS name)] sigs)) + (#Some name #Nil (` {}) sigs) + + _ + #None))] + (case ?parts + (#Some name args meta sigs) + (do Monad<Lux> + [name+ (normalize name) + sigs' (mapM Monad<Lux> macro-expand sigs) + members (: (Lux (List [Text AST])) + (mapM Monad<Lux> + (: (-> AST (Lux [Text AST])) + (lambda [token] + (case token + (^ [_ (#FormS (list [_ (#SymbolS _ "_lux_:")] type [_ (#SymbolS ["" name])]))]) + (wrap [name type]) + + _ + (fail "Signatures require typed members!")))) + (List/join sigs'))) + #let [[_module _name] name+ + def-name (symbol$ name) + sig-type (record$ (map (: (-> [Text AST] [AST AST]) + (lambda [[m-name m-type]] + [(tag$ ["" m-name]) m-type])) + members)) + sig-meta (meta-ast-merge (` {#;sig? true}) + meta) + usage (case args + #;Nil + def-name + + _ + (` ((~ def-name) (~@ args))))]] + (return (list (` (;;type: (~@ (export-level exported?)) (~ usage) (~ sig-meta) (~ sig-type)))))) + + #None + (fail "Wrong syntax for sig:")))) + +(def: (find f xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (Maybe b))) + (case xs + #Nil + #None + + (#Cons x xs') + (case (f x) + #None + (find f xs') + + (#Some y) + (#Some y)))) + +(def: (last-index-of part text) + (-> Text Text Int) + (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:lastIndexOf:java.lang.String"] [text part])])) + +(def: (index-of part text) + (-> Text Text Int) + (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:indexOf:java.lang.String"] [text part])])) + +(def: (substring1 idx text) + (-> Int Text Text) + (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int"] [text (_lux_proc ["jvm" "l2i"] [idx])])) + +(def: (substring2 idx1 idx2 text) + (-> Int Int Text Text) + (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] [text (_lux_proc ["jvm" "l2i"] [idx1]) (_lux_proc ["jvm" "l2i"] [idx2])])) + +(def: #export (log! message) + (-> Text Unit) + (_lux_proc ["jvm" "invokevirtual:java.io.PrintStream:println:java.lang.String"] + [(_lux_proc ["jvm" "getstatic:java.lang.System:out"] []) message])) + +(def: (split-text splitter input) + (-> Text Text (List Text)) + (let [idx (index-of splitter input)] + (if (i< idx 0) + (#Cons input #Nil) + (#Cons (substring2 0 idx input) + (split-text splitter (substring1 (i+ 1 idx) input)))))) + +(def: (split-module-contexts module) + (-> Text (List Text)) + (#Cons module (let [idx (last-index-of "/" module)] + (if (i< idx 0) + #Nil + (split-module-contexts (substring2 0 idx module)))))) + +(def: (split-module module) + (-> Text (List Text)) + (let [idx (index-of "/" module)] + (if (i< idx 0) + (list module) + (list& (substring2 0 idx module) (split-module (substring1 (i+ 1 idx) module)))))) + +(def: (at idx xs) + (All [a] + (-> Int (List a) (Maybe a))) + (case xs + #Nil + #None + + (#Cons x xs') + (if (i= idx 0) + (#Some x) + (at (i- idx 1) xs') + ))) + +(def: (beta-reduce env type) + (-> (List Type) Type Type) + (case type + (#SumT left right) + (#SumT (beta-reduce env left) (beta-reduce env right)) + + (#ProdT left right) + (#ProdT (beta-reduce env left) (beta-reduce env right)) + + (#AppT ?type-fn ?type-arg) + (#AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) + + (#UnivQ ?local-env ?local-def) + (case ?local-env + #Nil + (#UnivQ env ?local-def) + + _ + type) + + (#ExQ ?local-env ?local-def) + (case ?local-env + #Nil + (#ExQ env ?local-def) + + _ + type) + + (#LambdaT ?input ?output) + (#LambdaT (beta-reduce env ?input) (beta-reduce env ?output)) + + (#BoundT idx) + (case (at (_lux_proc ["nat" "to-int"] [idx]) env) + (#Some bound) + bound + + _ + type) + + (#NamedT name type) + (beta-reduce env type) + + _ + type + )) + +(def: (apply-type type-fn param) + (-> Type Type (Maybe Type)) + (case type-fn + (#UnivQ env body) + (#Some (beta-reduce (list& type-fn param env) body)) + + (#ExQ env body) + (#Some (beta-reduce (list& type-fn param env) body)) + + (#AppT F A) + (do Monad<Maybe> + [type-fn* (apply-type F A)] + (apply-type type-fn* param)) + + (#NamedT name type) + (apply-type type param) + + _ + #None)) + +(do-template [<name> <tag>] + [(def: (<name> type) + (-> Type (List Type)) + (case type + (<tag> left right) + (list& left (<name> right)) + + _ + (list type)))] + + [flatten-sum #;SumT] + [flatten-prod #;ProdT] + [flatten-lambda #;LambdaT] + [flatten-app #;AppT] + ) + +(def: (resolve-struct-type type) + (-> Type (Maybe (List Type))) + (case type + (#ProdT _) + (#Some (flatten-prod type)) + + (#AppT fun arg) + (do Monad<Maybe> + [output (apply-type fun arg)] + (resolve-struct-type output)) + + (#UnivQ _ body) + (resolve-struct-type body) + + (#ExQ _ body) + (resolve-struct-type body) + + (#NamedT name type) + (resolve-struct-type type) + + (#SumT _) + #None + + _ + (#Some (list type)))) + +(def: (find-module name) + (-> Text (Lux Module)) + (lambda [state] + (let [{#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} state] + (case (get name modules) + (#Some module) + (#Right state module) + + _ + (#Left ($_ Text/append "Unknown module: " name)))))) + +(def: get-current-module + (Lux Module) + (do Monad<Lux> + [module-name current-module-name] + (find-module module-name))) + +(def: (resolve-tag [module name]) + (-> Ident (Lux [Nat (List Ident) Bool Type])) + (do Monad<Lux> + [=module (find-module module) + #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags-table #types types #module-anns _} =module]] + (case (get name tags-table) + (#Some output) + (return output) + + _ + (fail (Text/append "Unknown tag: " (Ident->Text [module name])))))) + +(def: (resolve-type-tags type) + (-> Type (Lux (Maybe [(List Ident) (List Type)]))) + (case type + (#AppT fun arg) + (resolve-type-tags fun) + + (#UnivQ env body) + (resolve-type-tags body) + + (#ExQ env body) + (resolve-type-tags body) + + (#NamedT [module name] _) + (do Monad<Lux> + [=module (find-module module) + #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _} =module]] + (case (get name types) + (#Some [tags exported? (#NamedT _ _type)]) + (case (resolve-struct-type _type) + (#Some members) + (return (#Some [tags members])) + + _ + (return #None)) + + _ + (return #None))) + + _ + (return #None))) + +(def: get-expected-type + (Lux Type) + (lambda [state] + (let [{#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} state] + (case expected + (#Some type) + (#Right state type) + + #None + (#Left "Not expecting any type."))))) + +(macro: #export (struct tokens) + {#;doc "Not meant to be used directly. Prefer \"struct:\"."} + (do Monad<Lux> + [tokens' (mapM Monad<Lux> macro-expand tokens) + struct-type get-expected-type + tags+type (resolve-type-tags struct-type) + tags (: (Lux (List Ident)) + (case tags+type + (#Some [tags _]) + (return tags) + + _ + (fail "No tags available for type."))) + #let [tag-mappings (: (List [Text AST]) + (map (lambda [tag] [(second tag) (tag$ tag)]) + tags))] + members (mapM Monad<Lux> + (: (-> AST (Lux [AST AST])) + (lambda [token] + (case token + (^ [_ (#FormS (list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS "" tag-name)] value meta))]) + (case (get tag-name tag-mappings) + (#Some tag) + (wrap [tag value]) + + _ + (fail (Text/append "Unknown structure member: " tag-name))) + + _ + (fail "Invalid structure member.")))) + (List/join tokens'))] + (wrap (list (record$ members))))) + +(def: (Text/join parts) + (-> (List Text) Text) + (|> parts reverse (fold Text/append ""))) + +(macro: #export (struct: tokens) + {#;doc "## Definition of structures ala ML. + (struct: #export Ord<Int> (Ord Int) + (def: eq Eq<Int>) + (def: (< test subject) + (lux;< test subject)) + (def: (<= test subject) + (or (lux;< test subject) + (lux;= test subject))) + (def: (lux;> test subject) + (lux;> test subject)) + (def: (lux;>= test subject) + (or (lux;> test subject) + (lux;= test subject))))"} + (let [[exported? tokens'] (export-level^ tokens) + ?parts (: (Maybe [AST (List AST) AST AST (List AST)]) + (case tokens' + (^ (list& [_ (#FormS (list& name args))] type [meta-rec-cursor (#;RecordS meta-rec-parts)] defs)) + (#Some name args type [meta-rec-cursor (#;RecordS meta-rec-parts)] defs) + + (^ (list& name type [meta-rec-cursor (#;RecordS meta-rec-parts)] defs)) + (#Some name #Nil type [meta-rec-cursor (#;RecordS meta-rec-parts)] defs) + + (^ (list& [_ (#FormS (list& name args))] type defs)) + (#Some name args type (` {}) defs) + + (^ (list& name type defs)) + (#Some name #Nil type (` {}) defs) + + _ + #None))] + (case ?parts + (#Some [name args type meta defs]) + (case (case name + [_ (#;SymbolS ["" "_"])] + (case type + (^ [_ (#;FormS (list& [_ (#;SymbolS [_ sig-name])] sig-args))]) + (case (: (Maybe (List Text)) + (mapM Monad<Maybe> + (lambda [sa] + (case sa + [_ (#;SymbolS [_ arg-name])] + (#;Some arg-name) + + _ + #;None)) + sig-args)) + (^ (#;Some params)) + (#;Some (symbol$ ["" ($_ Text/append sig-name "<" (|> params (interpose ",") Text/join) ">")])) + + _ + #;None) + + _ + #;None) + + _ + (#;Some name) + ) + (#;Some name) + (let [usage (case args + #Nil + name + + _ + (` ((~ name) (~@ args))))] + (return (list (` (;;def: (~@ (export-level exported?)) (~ usage) + (~ (meta-ast-merge (` {#;struct? true}) + meta)) + (~ type) + (struct (~@ defs))))))) + + #;None + (fail "Struct must have a name other than \"_\"!")) + + #None + (fail "Wrong syntax for struct:")))) + +(def: #export (id x) + {#;doc "Identity function. Does nothing to it's argument and just returns it."} + (All [a] (-> a a)) + x) + +(do-template [<name> <form> <message> <doc-msg>] + [(macro: #export (<name> tokens) + {#;doc <doc-msg>} + (case (reverse tokens) + (^ (list& last init)) + (return (list (fold (: (-> AST AST AST) + (lambda [pre post] (` <form>))) + last + init))) + + _ + (fail <message>)))] + + [and (if (~ pre) (~ post) false) "'and' requires >=1 clauses." "Short-circuiting \"and\"\n(and true false true) ## => false"] + [or (if (~ pre) true (~ post)) "'or' requires >=1 clauses." "Short-circuiting \"or\"\n(or true false true) ## => true"]) + +(macro: #export (type: tokens) + {#;doc "## The type-definition macro. + (type: (List a) + #Nil + (#Cons a (List a)))"} + (let [[exported? tokens'] (export-level^ tokens) + [rec? tokens'] (case tokens' + (#Cons [_ (#TagS [_ "rec"])] tokens') + [true tokens'] + + _ + [false tokens']) + parts (: (Maybe [Text (List AST) AST (List AST)]) + (case tokens' + (^ (list [_ (#SymbolS "" name)] [meta-cursor (#;RecordS meta-parts)] [type-cursor (#;RecordS type-parts)])) + (#Some [name #Nil [meta-cursor (#;RecordS meta-parts)] (list [type-cursor (#;RecordS type-parts)])]) + + (^ (list& [_ (#SymbolS "" name)] [meta-cursor (#;RecordS meta-parts)] type-ast1 type-asts)) + (#Some [name #Nil [meta-cursor (#;RecordS meta-parts)] (#;Cons type-ast1 type-asts)]) + + (^ (list& [_ (#SymbolS "" name)] type-asts)) + (#Some [name #Nil (` {}) type-asts]) + + (^ (list [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] [meta-cursor (#;RecordS meta-parts)] [type-cursor (#;RecordS type-parts)])) + (#Some [name args [meta-cursor (#;RecordS meta-parts)] (list [type-cursor (#;RecordS type-parts)])]) + + (^ (list& [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] [meta-cursor (#;RecordS meta-parts)] type-ast1 type-asts)) + (#Some [name args [meta-cursor (#;RecordS meta-parts)] (#;Cons type-ast1 type-asts)]) + + (^ (list& [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] type-asts)) + (#Some [name args (` {}) type-asts]) + + _ + #None))] + (case parts + (#Some name args meta type-asts) + (do Monad<Lux> + [type+tags?? (unfold-type-def type-asts) + module-name current-module-name] + (let [type-name (symbol$ ["" name]) + [type tags??] type+tags?? + type-meta (: AST + (case tags?? + (#Some tags) + (` {#;tags [(~@ (map (: (-> Text AST) + (lambda' [tag] + (form$ (list (tag$ ["lux" "TextM"]) + (text$ tag))))) + tags))] + #;type? true}) + + _ + (` {#;type? true}))) + type' (: (Maybe AST) + (if rec? + (if (empty? args) + (let [g!param (symbol$ ["" ""]) + prime-name (symbol$ ["" (Text/append name "'")]) + type+ (replace-syntax (list [name (` ((~ prime-name) (~ g!param)))]) type)] + (#Some (` ((All (~ prime-name) [(~ g!param)] (~ type+)) + Void)))) + #None) + (case args + #Nil + (#Some type) + + _ + (#Some (` (All (~ type-name) [(~@ args)] (~ type)))))))] + (case type' + (#Some type'') + (return (list (` (;;def: (~@ (export-level exported?)) (~ type-name) + (~ ($_ meta-ast-merge (with-type-args args) + (if rec? (' {#;type-rec? true}) (' {})) + type-meta + meta)) + Type + (#;NamedT [(~ (text$ module-name)) + (~ (text$ name))] + (type (~ type''))))))) + + #None + (fail "Wrong syntax for type:")))) + + #None + (fail "Wrong syntax for type:")) + )) + +(type: Referrals + #All + (#Only (List Text)) + (#Exclude (List Text)) + #Nothing) + +(type: Openings + [Text (List Ident)]) + +(type: Refer + {#refer-defs Referrals + #refer-open (List Openings)}) + +(type: Importation + {#import-name Text + #import-alias (Maybe Text) + #import-refer Refer}) + +(def: (extract-defs defs) + (-> (List AST) (Lux (List Text))) + (mapM Monad<Lux> + (: (-> AST (Lux Text)) + (lambda [def] + (case def + [_ (#SymbolS ["" name])] + (return name) + + _ + (fail "only/exclude requires symbols.")))) + defs)) + +(def: (parse-alias tokens) + (-> (List AST) (Lux [(Maybe Text) (List AST)])) + (case tokens + (^ (list& [_ (#TagS "" "as")] [_ (#SymbolS "" alias)] tokens')) + (return [(#Some alias) tokens']) + + _ + (return [#None tokens]))) + +(def: (parse-referrals tokens) + (-> (List AST) (Lux [Referrals (List AST)])) + (case tokens + (^ (list& [_ (#TagS ["" "refer"])] referral tokens')) + (case referral + [_ (#TagS "" "all")] + (return [#All tokens']) + + (^ [_ (#FormS (list& [_ (#TagS ["" "only"])] defs))]) + (do Monad<Lux> + [defs' (extract-defs defs)] + (return [(#Only defs') tokens'])) + + (^ [_ (#FormS (list& [_ (#TagS ["" "exclude"])] defs))]) + (do Monad<Lux> + [defs' (extract-defs defs)] + (return [(#Exclude defs') tokens'])) + + _ + (fail "Incorrect syntax for referral.")) + + _ + (return [#Nothing tokens]))) + +(def: (split-with' p ys xs) + (All [a] + (-> (-> a Bool) (List a) (List a) [(List a) (List a)])) + (case xs + #Nil + [ys xs] + + (#Cons x xs') + (if (p x) + (split-with' p (list& x ys) xs') + [ys xs]))) + +(def: (split-with p xs) + (All [a] + (-> (-> a Bool) (List a) [(List a) (List a)])) + (let [[ys' xs'] (split-with' p #Nil xs)] + [(reverse ys') xs'])) + +(def: (parse-short-referrals tokens) + (-> (List AST) (Lux [Referrals (List AST)])) + (case tokens + (^ (list& [_ (#TagS "" "+")] tokens')) + (let [[defs tokens'] (split-with symbol? tokens')] + (do Monad<Lux> + [defs' (extract-defs defs)] + (return [(#Only defs') tokens']))) + + (^ (list& [_ (#TagS "" "-")] tokens')) + (let [[defs tokens'] (split-with symbol? tokens')] + (do Monad<Lux> + [defs' (extract-defs defs)] + (return [(#Exclude defs') tokens']))) + + (^ (list& [_ (#TagS "" "*")] tokens')) + (return [#All tokens']) + + _ + (return [#Nothing tokens]))) + +(def: (extract-symbol syntax) + (-> AST (Lux Ident)) + (case syntax + [_ (#SymbolS ident)] + (return ident) + + _ + (fail "Not a symbol."))) + +(def: (parse-openings tokens) + (-> (List AST) (Lux [(List Openings) (List AST)])) + (case tokens + (^ (list& [_ (#TagS "" "open")] [_ (#FormS parts)] tokens')) + (if (|> parts + (map (: (-> AST Bool) + (lambda [part] + (case part + (^or [_ (#TextS _)] [_ (#SymbolS _)]) + true + + _ + false)))) + (fold (lambda [r l] (and l r)) true)) + (let [openings (fold (: (-> AST (List Openings) (List Openings)) + (lambda [part openings] + (case part + [_ (#TextS prefix)] + (list& [prefix (list)] openings) + + [_ (#SymbolS struct-name)] + (case openings + #Nil + (list ["" (list struct-name)]) + + (#Cons [prefix structs] openings') + (#Cons [prefix (#Cons struct-name structs)] openings')) + + _ + openings))) + (: (List Openings) (list)) + parts)] + (return [openings tokens'])) + (fail "Expected all parts of opening form to be of either prefix (text) or struct (symbol).")) + + _ + (return [(list) tokens]))) + +(def: (parse-short-openings parts) + (-> (List AST) (Lux [(List Openings) (List AST)])) + (if (|> parts + (map (: (-> AST Bool) + (lambda [part] + (case part + (^or [_ (#TextS _)] [_ (#SymbolS _)]) + true + + _ + false)))) + (fold (lambda [r l] (and l r)) true)) + (let [openings (fold (: (-> AST (List Openings) (List Openings)) + (lambda [part openings] + (case part + [_ (#TextS prefix)] + (list& [prefix (list)] openings) + + [_ (#SymbolS struct-name)] + (case openings + #Nil + (list ["" (list struct-name)]) + + (#Cons [prefix structs] openings') + (#Cons [prefix (#Cons struct-name structs)] openings')) + + _ + openings))) + (: (List Openings) (list)) + parts)] + (return [openings (list)])) + (fail "Expected all parts of opening form to be of either prefix (text) or struct (symbol)."))) + +(def: (decorate-sub-importations super-name) + (-> Text (List Importation) (List Importation)) + (map (: (-> Importation Importation) + (lambda [importation] + (let [{#import-name _name + #import-alias _alias + #import-refer {#refer-defs _referrals + #refer-open _openings}} importation] + {#import-name ($_ Text/append super-name "/" _name) + #import-alias _alias + #import-refer {#refer-defs _referrals + #refer-open _openings}}))))) + +(def: (replace pattern value template) + (-> Text Text Text Text) + (_lux_proc ["jvm" "invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"] [template pattern value])) + +(def: (clean-module module) + (-> Text (Lux Text)) + (do Monad<Lux> + [module-name current-module-name] + (case (split-module module) + (^ (list& "." parts)) + (return (|> (list& module-name parts) (interpose "/") reverse (fold Text/append ""))) + + parts + (let [[ups parts'] (split-with (Text/= "..") parts) + num-ups (length ups)] + (if (i= num-ups 0) + (return module) + (case (at num-ups (split-module-contexts module-name)) + #None + (fail (Text/append "Can't clean module: " module)) + + (#Some top-module) + (return (|> (list& top-module parts') (interpose "/") reverse (fold Text/append "")))) + ))) + )) + +(def: (parse-imports imports) + (-> (List AST) (Lux (List Importation))) + (do Monad<Lux> + [imports' (mapM Monad<Lux> + (: (-> AST (Lux (List Importation))) + (lambda [token] + (case token + [_ (#SymbolS "" m-name)] + (do Monad<Lux> + [m-name (clean-module m-name)] + (wrap (list [m-name #None {#refer-defs #All #refer-open (list)}]))) + + (^ [_ (#FormS (list& [_ (#SymbolS "" m-name)] extra))]) + (do Monad<Lux> + [m-name (clean-module m-name) + alias+extra (parse-alias extra) + #let [[alias extra] alias+extra] + referral+extra (parse-referrals extra) + #let [[referral extra] referral+extra] + openings+extra (parse-openings extra) + #let [[openings extra] openings+extra] + sub-imports (parse-imports extra) + #let [sub-imports (decorate-sub-importations m-name sub-imports)]] + (wrap (case [referral alias openings] + [#Nothing #None #Nil] sub-imports + _ (list& {#import-name m-name + #import-alias alias + #import-refer {#refer-defs referral + #refer-open openings}} + sub-imports)))) + + (^ [_ (#TupleS (list& [_ (#TextS alias)] [_ (#SymbolS "" m-name)] extra))]) + (do Monad<Lux> + [m-name (clean-module m-name) + referral+extra (parse-short-referrals extra) + #let [[referral extra] referral+extra] + openings+extra (parse-short-openings extra) + #let [[openings extra] openings+extra]] + (wrap (list {#import-name m-name + #import-alias (#;Some (replace ";" m-name alias)) + #import-refer {#refer-defs referral + #refer-open openings}}))) + + (^ [_ (#TupleS (list& [_ (#SymbolS "" m-name)] extra))]) + (do Monad<Lux> + [m-name (clean-module m-name) + referral+extra (parse-short-referrals extra) + #let [[referral extra] referral+extra] + openings+extra (parse-short-openings extra) + #let [[openings extra] openings+extra]] + (wrap (list {#import-name m-name + #import-alias (#;Some m-name) + #import-refer {#refer-defs referral + #refer-open openings}}))) + + _ + (do Monad<Lux> + [current-module current-module-name] + (fail (Text/append "Wrong syntax for import @ " current-module)))))) + imports)] + (wrap (List/join imports')))) + +(def: (exported-defs module state) + (-> Text (Lux (List Text))) + (let [modules (case state + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} + modules)] + (case (get module modules) + (#Some =module) + (let [to-alias (map (: (-> [Text Def] + (List Text)) + (lambda [[name [def-type def-meta def-value]]] + (case [(get-meta ["lux" "export?"] def-meta) + (get-meta ["lux" "hidden?"] def-meta)] + [(#Some (#BoolM true)) #;None] + (list name) + + _ + (list)))) + (let [{#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _} =module] + defs))] + (#Right state (List/join to-alias))) + + #None + (#Left ($_ Text/append "Unknown module: " module))) + )) + +(def: (filter p xs) + (All [a] (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + (list) + + (#;Cons x xs') + (if (p x) + (#;Cons x (filter p xs')) + (filter p xs')))) + +(def: (is-member? cases name) + (-> (List Text) Text Bool) + (let [output (fold (lambda [case prev] + (or prev + (Text/= case name))) + false + cases)] + output)) + +(def: (try-both f x1 x2) + (All [a b] + (-> (-> a (Maybe b)) a a (Maybe b))) + (case (f x1) + #;None (f x2) + (#;Some y) (#;Some y))) + +(def: (find-in-env name state) + (-> Text Compiler (Maybe Type)) + (case state + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} + (find (: (-> Scope (Maybe Type)) + (lambda [env] + (case env + {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} + (try-both (find (: (-> [Text Analysis] (Maybe Type)) + (lambda [[bname [[type _] _]]] + (if (Text/= name bname) + (#Some type) + #None)))) + locals + closure)))) + scopes))) + +(def: (find-def-type name state) + (-> Ident Compiler (Maybe Type)) + (let [[v-prefix v-name] name + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} state] + (case (get v-prefix modules) + #None + #None + + (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _}) + (case (get v-name defs) + #None + #None + + (#Some [def-type def-meta def-value]) + (#Some def-type))))) + +(def: (find-def-value name state) + (-> Ident (Lux [Type Unit])) + (let [[v-prefix v-name] name + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} state] + (case (get v-prefix modules) + #None + (#Left (Text/append "Unknown definition: " (Ident->Text name))) + + (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _}) + (case (get v-name defs) + #None + (#Left (Text/append "Unknown definition: " (Ident->Text name))) + + (#Some [def-type def-meta def-value]) + (#Right [state [def-type def-value]]))))) + +(def: (find-type ident) + (-> Ident (Lux Type)) + (do Monad<Lux> + [#let [[module name] ident] + current-module current-module-name] + (lambda [state] + (if (Text/= "" module) + (case (find-in-env name state) + (#Some struct-type) + (#Right state struct-type) + + _ + (case (find-def-type [current-module name] state) + (#Some struct-type) + (#Right state struct-type) + + _ + (#Left ($_ Text/append "Unknown var: " (Ident->Text ident))))) + (case (find-def-type ident state) + (#Some struct-type) + (#Right state struct-type) + + _ + (#Left ($_ Text/append "Unknown var: " (Ident->Text ident))))) + ))) + +(def: (zip2 xs ys) + (All [a b] (-> (List a) (List b) (List [a b]))) + (case xs + (#Cons x xs') + (case ys + (#Cons y ys') + (list& [x y] (zip2 xs' ys')) + + _ + (list)) + + _ + (list))) + +(def: (use-field prefix [module name] type) + (-> Text Ident Type (Lux [AST AST])) + (do Monad<Lux> + [output (resolve-type-tags type) + pattern (: (Lux AST) + (case output + (#Some [tags members]) + (do Monad<Lux> + [slots (mapM Monad<Lux> + (: (-> [Ident Type] (Lux [AST AST])) + (lambda [[sname stype]] (use-field prefix sname stype))) + (zip2 tags members))] + (return (record$ slots))) + + #None + (return (symbol$ ["" (Text/append prefix name)]))))] + (return [(tag$ [module name]) pattern]))) + +(def: (Type/show type) + (-> Type Text) + (case type + (#HostT name params) + (case params + #;Nil + name + + _ + ($_ Text/append "(" name " " (|> params (map Type/show) (interpose " ") reverse (fold Text/append "")) ")")) + + #VoidT + "Void" + + #UnitT + "Unit" + + (#SumT _) + ($_ Text/append "(| " (|> (flatten-sum type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")") + + (#ProdT _) + ($_ Text/append "[" (|> (flatten-prod type) (map Type/show) (interpose " ") reverse (fold Text/append "")) "]") + + (#LambdaT _) + ($_ Text/append "(-> " (|> (flatten-lambda type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")") + + (#BoundT id) + (Nat->Text id) + + (#VarT id) + ($_ Text/append "⌈v:" (->Text id) "⌋") + + (#ExT id) + ($_ Text/append "⟨e:" (->Text id) "⟩") + + (#UnivQ env body) + ($_ Text/append "(All " (Type/show body) ")") + + (#ExQ env body) + ($_ Text/append "(Ex " (Type/show body) ")") + + (#AppT _) + ($_ Text/append "(" (|> (flatten-app type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")") + + (#NamedT [prefix name] _) + ($_ Text/append prefix ";" name) + )) + +(macro: #hidden (^open' tokens) + (case tokens + (^ (list [_ (#SymbolS name)] [_ (#TextS prefix)] body)) + (do Monad<Lux> + [struct-type (find-type name) + output (resolve-type-tags struct-type)] + (case output + (#Some [tags members]) + (do Monad<Lux> + [slots (mapM Monad<Lux> (: (-> [Ident Type] (Lux [AST AST])) + (lambda [[sname stype]] (use-field prefix sname stype))) + (zip2 tags members)) + #let [pattern (record$ slots)]] + (return (list (` (;_lux_case (~ (symbol$ name)) (~ pattern) (~ body)))))) + + _ + (fail (Text/append "Can only \"open\" structs: " (Type/show struct-type))))) + + _ + (fail "Wrong syntax for ^open"))) + +(macro: #export (^open tokens) + {#;doc "## Same as the \"open\" macro, but meant to be used as a pattern-matching macro for generating local bindings. + ## Can optionally take a \"prefix\" text for the generated local bindings. + (def: #export (range (^open) from to) + (All [a] (-> (Enum a) a a (List a))) + (range' <= succ from to))"} + (case tokens + (^ (list& [_ (#FormS (list [_ (#TextS prefix)]))] body branches)) + (do Monad<Lux> + [g!temp (gensym "temp")] + (return (list& g!temp (` (^open' (~ g!temp) (~ (text$ prefix)) (~ body))) branches))) + + (^ (list& [_ (#FormS (list))] body branches)) + (return (list& (` (;;^open "")) body branches)) + + _ + (fail "Wrong syntax for ^open"))) + +(macro: #export (cond tokens) + {#;doc "## Branching structures with multiple test conditions. + (cond (even? num) \"even\" + (odd? num) \"odd\" + ## else-branch + \"???\")"} + (if (i= 0 (i% (length tokens) 2)) + (fail "cond requires an even number of arguments.") + (case (reverse tokens) + (^ (list& else branches')) + (return (list (fold (: (-> [AST AST] AST AST) + (lambda [branch else] + (let [[right left] branch] + (` (if (~ left) (~ right) (~ else)))))) + else + (as-pairs branches')))) + + _ + (fail "Wrong syntax for cond")))) + +(def: (enumerate' idx xs) + (All [a] (-> Nat (List a) (List [Nat a]))) + (case xs + (#Cons x xs') + (#Cons [idx x] (enumerate' (n+ +1 idx) xs')) + + #Nil + #Nil)) + +(def: (enumerate xs) + (All [a] (-> (List a) (List [Nat a]))) + (enumerate' +0 xs)) + +(macro: #export (get@ tokens) + {#;doc "## Accesses the value of a record at a given tag. + (get@ #field my-record) + + ## Can also work with multiple levels of nesting: + (get@ [#foo #bar #baz] my-record) + + ## And, if only the slot/path is given, generates an + ## accessor function: + (let [getter (get@ [#foo #bar #baz])] + (getter my-record))"} + (case tokens + (^ (list [_ (#TagS slot')] record)) + (do Monad<Lux> + [slot (normalize slot') + output (resolve-tag slot) + #let [[idx tags exported? type] output] + g!_ (gensym "_") + g!output (gensym "")] + (case (resolve-struct-type type) + (#Some members) + (let [pattern (record$ (map (: (-> [Ident [Nat Type]] [AST AST]) + (lambda [[[r-prefix r-name] [r-idx r-type]]] + [(tag$ [r-prefix r-name]) (if (n= idx r-idx) + g!output + g!_)])) + (zip2 tags (enumerate members))))] + (return (list (` (;_lux_case (~ record) (~ pattern) (~ g!output)))))) + + _ + (fail "get@ can only use records."))) + + (^ (list [_ (#TupleS slots)] record)) + (return (list (fold (: (-> AST AST AST) + (lambda [slot inner] + (` (;;get@ (~ slot) (~ inner))))) + record + slots))) + + (^ (list selector)) + (do Monad<Lux> + [g!record (gensym "record")] + (wrap (list (` (lambda [(~ g!record)] (;;get@ (~ selector) (~ g!record))))))) + + _ + (fail "Wrong syntax for get@"))) + +(def: (open-field prefix [module name] source type) + (-> Text Ident AST Type (Lux (List AST))) + (do Monad<Lux> + [output (resolve-type-tags type) + #let [source+ (` (get@ (~ (tag$ [module name])) (~ source)))]] + (case output + (#Some [tags members]) + (do Monad<Lux> + [decls' (mapM Monad<Lux> + (: (-> [Ident Type] (Lux (List AST))) + (lambda [[sname stype]] (open-field prefix sname source+ stype))) + (zip2 tags members))] + (return (List/join decls'))) + + _ + (return (list (` (;_lux_def (~ (symbol$ ["" (Text/append prefix name)])) (~ source+) + #Nil))))))) + +(macro: #export (open tokens) + {#;doc "## Opens a structure and generates a definition for each of its members (including nested members). + ## For example: + (open Number<Int> \"i:\") + ## Will generate: + (def: i:+ (:: Number<Int> +)) + (def: i:- (:: Number<Int> -)) + (def: i:* (:: Number<Int> *)) + ..."} + (case tokens + (^ (list& [_ (#SymbolS struct-name)] tokens')) + (do Monad<Lux> + [@module current-module-name + #let [prefix (case tokens' + (^ (list [_ (#TextS prefix)])) + prefix + + _ + "")] + struct-type (find-type struct-name) + output (resolve-type-tags struct-type) + #let [source (symbol$ struct-name)]] + (case output + (#Some [tags members]) + (do Monad<Lux> + [decls' (mapM Monad<Lux> (: (-> [Ident Type] (Lux (List AST))) + (lambda [[sname stype]] (open-field prefix sname source stype))) + (zip2 tags members))] + (return (List/join decls'))) + + _ + (fail (Text/append "Can only \"open\" structs: " (Type/show struct-type))))) + + _ + (fail "Wrong syntax for open"))) + +(macro: #export (|>. tokens) + {#;doc "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it. + (|> (map ->Text) (interpose \" \") (fold Text/append \"\")) + ## => + (lambda [<something>] + (fold Text/append \"\" + (interpose \" \" + (map ->Text <something>))))"} + (do Monad<Lux> + [g!arg (gensym "arg")] + (return (list (` (lambda [(~ g!arg)] (|> (~ g!arg) (~@ tokens)))))))) + +(def: (imported-by? import-name module-name) + (-> Text Text (Lux Bool)) + (do Monad<Lux> + [module (find-module module-name) + #let [{#module-hash _ #module-aliases _ #defs _ #imports imports #tags _ #types _ #module-anns _} module]] + (wrap (is-member? imports import-name)))) + +(macro: #export (default tokens state) + {#;doc "## Allows you to provide a default value that will be used + ## if a (Maybe x) value turns out to be #;Some. + (default 20 (#;Some 10)) => 10 + + (default 20 #;None) => 20"} + (case tokens + (^ (list else maybe)) + (let [g!temp (: AST [["" -1 -1] (#;SymbolS ["" ""])]) + code (` (case (~ maybe) + (#;Some (~ g!temp)) + (~ g!temp) + + #;None + (~ else)))] + (#;Right [state (list code)])) + + _ + (#;Left "Wrong syntax for ?"))) + +(def: (read-refer module-name options) + (-> Text (List AST) (Lux Refer)) + (do Monad<Lux> + [referral+options (parse-referrals options) + #let [[referral options] referral+options] + openings+options (parse-openings options) + #let [[openings options] openings+options] + current-module current-module-name + #let [test-referrals (: (-> Text (List Text) (List Text) (Lux (List Unit))) + (lambda [module-name all-defs referred-defs] + (mapM Monad<Lux> + (: (-> Text (Lux Unit)) + (lambda [_def] + (if (is-member? all-defs _def) + (return []) + (fail ($_ Text/append _def " is not defined in module " module-name " @ " current-module))))) + referred-defs)))]] + (case options + #;Nil + (wrap {#refer-defs referral + #refer-open openings}) + + _ + (fail ($_ Text/append "Wrong syntax for refer @ " current-module + "\n" (|> options + (map ast-to-text) + (interpose " ") + (fold Text/append ""))))))) + +(def: (write-refer module-name [r-defs r-opens]) + (-> Text Refer (Lux (List AST))) + (do Monad<Lux> + [current-module current-module-name + #let [test-referrals (: (-> Text (List Text) (List Text) (Lux (List Unit))) + (lambda [module-name all-defs referred-defs] + (mapM Monad<Lux> + (: (-> Text (Lux Unit)) + (lambda [_def] + (if (is-member? all-defs _def) + (return []) + (fail ($_ Text/append _def " is not defined in module " module-name " @ " current-module))))) + referred-defs)))] + defs' (case r-defs + #All + (exported-defs module-name) + + (#Only +defs) + (do Monad<Lux> + [*defs (exported-defs module-name) + _ (test-referrals module-name *defs +defs)] + (wrap +defs)) + + (#Exclude -defs) + (do Monad<Lux> + [*defs (exported-defs module-name) + _ (test-referrals module-name *defs -defs)] + (wrap (filter (|>. (is-member? -defs) not) *defs))) + + #Nothing + (wrap (list))) + #let [defs (map (: (-> Text AST) + (lambda [def] + (` (;_lux_def (~ (symbol$ ["" def])) + (~ (symbol$ [module-name def])) + (#Cons [["lux" "alias"] (#IdentM [(~ (text$ module-name)) (~ (text$ def))])] + #Nil))))) + defs') + openings (join-map (: (-> Openings (List AST)) + (lambda [[prefix structs]] + (map (lambda [[_ name]] (` (open (~ (symbol$ [module-name name])) (~ (text$ prefix))))) + structs))) + r-opens)]] + (wrap (List/append defs openings)) + )) + +(macro: #export (refer tokens) + (case tokens + (^ (list& [_ (#TextS module-name)] options)) + (do Monad<Lux> + [=refer (read-refer module-name options)] + (write-refer module-name =refer)) + + _ + (fail "Wrong syntax for refer"))) + +(def: (refer-to-ast module-name [r-defs r-opens]) + (-> Text Refer AST) + (let [=defs (: (List AST) + (case r-defs + #All + (list (' #refer) (' #all)) + + (#Only defs) + (list (' #refer) (`' (#only (~@ (map (|>. [""] symbol$) + defs))))) + + (#Exclude defs) + (list (' #refer) (`' (#exclude (~@ (map (|>. [""] symbol$) + defs))))) + + #Nothing + (list))) + =opens (join-map (lambda [[prefix structs]] + (list& (text$ prefix) (map symbol$ structs))) + r-opens)] + (` (;;refer (~ (text$ module-name)) + (~@ =defs) + (~' #open) ((~@ =opens)))))) + +(macro: #export (module: tokens) + {#;doc "## Examples + (;module: {#;doc \"Some documentation...\"} + lux + (lux (control (monad #as M #refer #all)) + (data (text #open (\"Text/\" Monoid<Text>)) + (struct (list #open (\"List/\" Monad<List>))) + maybe + (ident #open (\"Ident/\" Codec<Text,Ident>))) + meta + (macro ast)) + (.. (type #open (\"\" Eq<Type>)))) + + (;module: {#;doc \"Some documentation...\"} + lux + (lux (control [\"M\" monad #*]) + (data [text \"Text/\" Monoid<Text>] + (struct [list \"List/\" Monad<List>]) + maybe + [ident \"Ident/\" Codec<Text,Ident>]) + meta + (macro ast)) + (.. [type \"\" Eq<Type>]))"} + (do Monad<Lux> + [#let [[_meta _imports] (: [(List [AST AST]) (List AST)] + (case tokens + (^ (list& [_ (#RecordS _meta)] _imports)) + [_meta _imports] + + _ + [(list) tokens]))] + imports (parse-imports _imports) + #let [=imports (map (: (-> Importation AST) + (lambda [[m-name m-alias =refer]] + (` [(~ (text$ m-name)) (~ (text$ (default "" m-alias)))]))) + imports) + =refers (map (: (-> Importation AST) + (lambda [[m-name m-alias =refer]] + (refer-to-ast m-name =refer))) + imports)] + =meta (process-def-meta (record$ (list& [(` #;imports) (` [(~@ =imports)])] + _meta))) + #let [=module (` (;_lux_module (~ =meta)))]] + (wrap (#;Cons =module =refers)))) + +(macro: #export (:: tokens) + {#;doc "## Allows accessing the value of a structure's member. + (:: Codec<Text,Int> encode) + + ## Also allows using that value as a function. + (:: Codec<Text,Int> encode 123)"} + (case tokens + (^ (list struct [_ (#SymbolS member)])) + (return (list (` (let [(^open) (~ struct)] (~ (symbol$ member)))))) + + (^ (list& struct [_ (#SymbolS member)] args)) + (return (list (` ((let [(^open) (~ struct)] (~ (symbol$ member))) (~@ args))))) + + _ + (fail "Wrong syntax for ::"))) + +(macro: #export (set@ tokens) + {#;doc "## Sets the value of a record at a given tag. + (set@ #name \"Lux\" lang) + + ## Can also work with multiple levels of nesting: + (set@ [#foo #bar #baz] value my-record) + + ## And, if only the slot/path and (optionally) the value are given, generates a + ## mutator function: + (let [setter (set@ [#foo #bar #baz] value)] + (setter my-record)) + + (let [setter (set@ [#foo #bar #baz])] + (setter value my-record))"} + (case tokens + (^ (list [_ (#TagS slot')] value record)) + (do Monad<Lux> + [slot (normalize slot') + output (resolve-tag slot) + #let [[idx tags exported? type] output]] + (case (resolve-struct-type type) + (#Some members) + (do Monad<Lux> + [pattern' (mapM Monad<Lux> + (: (-> [Ident [Nat Type]] (Lux [Ident Nat AST])) + (lambda [[r-slot-name [r-idx r-type]]] + (do Monad<Lux> + [g!slot (gensym "")] + (return [r-slot-name r-idx g!slot])))) + (zip2 tags (enumerate members)))] + (let [pattern (record$ (map (: (-> [Ident Nat AST] [AST AST]) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) r-var])) + pattern')) + output (record$ (map (: (-> [Ident Nat AST] [AST AST]) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) (if (n= idx r-idx) + value + r-var)])) + pattern'))] + (return (list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) + + _ + (fail "set@ can only use records."))) + + (^ (list [_ (#TupleS slots)] value record)) + (case slots + #;Nil + (fail "Wrong syntax for set@") + + _ + (do Monad<Lux> + [bindings (mapM Monad<Lux> + (: (-> AST (Lux AST)) + (lambda [_] (gensym "temp"))) + slots) + #let [pairs (zip2 slots bindings) + update-expr (fold (: (-> [AST AST] AST AST) + (lambda [[s b] v] + (` (;;set@ (~ s) (~ v) (~ b))))) + value + (reverse pairs)) + [_ accesses'] (fold (: (-> [AST AST] [AST (List (List AST))] [AST (List (List AST))]) + (lambda [[new-slot new-binding] [old-record accesses']] + [(` (get@ (~ new-slot) (~ new-binding))) + (#;Cons (list new-binding old-record) accesses')])) + [record (: (List (List AST)) #;Nil)] + pairs) + accesses (List/join (reverse accesses'))]] + (wrap (list (` (let [(~@ accesses)] + (~ update-expr))))))) + + (^ (list selector value)) + (do Monad<Lux> + [g!record (gensym "record")] + (wrap (list (` (lambda [(~ g!record)] (;;set@ (~ selector) (~ value) (~ g!record))))))) + + (^ (list selector)) + (do Monad<Lux> + [g!value (gensym "value") + g!record (gensym "record")] + (wrap (list (` (lambda [(~ g!value) (~ g!record)] (;;set@ (~ selector) (~ g!value) (~ g!record))))))) + + _ + (fail "Wrong syntax for set@"))) + +(macro: #export (update@ tokens) + {#;doc "## Modifies the value of a record at a given tag, based on some function. + (update@ #age inc person) + + ## Can also work with multiple levels of nesting: + (update@ [#foo #bar #baz] func my-record) + + ## And, if only the slot/path and (optionally) the value are given, generates a + ## mutator function: + (let [updater (update@ [#foo #bar #baz] func)] + (updater my-record)) + + (let [updater (update@ [#foo #bar #baz])] + (updater func my-record))"} + (case tokens + (^ (list [_ (#TagS slot')] fun record)) + (do Monad<Lux> + [slot (normalize slot') + output (resolve-tag slot) + #let [[idx tags exported? type] output]] + (case (resolve-struct-type type) + (#Some members) + (do Monad<Lux> + [pattern' (mapM Monad<Lux> + (: (-> [Ident [Nat Type]] (Lux [Ident Nat AST])) + (lambda [[r-slot-name [r-idx r-type]]] + (do Monad<Lux> + [g!slot (gensym "")] + (return [r-slot-name r-idx g!slot])))) + (zip2 tags (enumerate members)))] + (let [pattern (record$ (map (: (-> [Ident Nat AST] [AST AST]) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) r-var])) + pattern')) + output (record$ (map (: (-> [Ident Nat AST] [AST AST]) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) (if (n= idx r-idx) + (` ((~ fun) (~ r-var))) + r-var)])) + pattern'))] + (return (list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) + + _ + (fail "update@ can only use records."))) + + (^ (list [_ (#TupleS slots)] fun record)) + (case slots + #;Nil + (fail "Wrong syntax for update@") + + _ + (do Monad<Lux> + [g!record (gensym "record") + g!temp (gensym "temp")] + (wrap (list (` (let [(~ g!record) (~ record) + (~ g!temp) (get@ [(~@ slots)] (~ g!record))] + (set@ [(~@ slots)] ((~ fun) (~ g!temp)) (~ g!record)))))))) + + (^ (list selector fun)) + (do Monad<Lux> + [g!record (gensym "record")] + (wrap (list (` (lambda [(~ g!record)] (;;update@ (~ selector) (~ fun) (~ g!record))))))) + + (^ (list selector)) + (do Monad<Lux> + [g!fun (gensym "fun") + g!record (gensym "record")] + (wrap (list (` (lambda [(~ g!fun) (~ g!record)] (;;update@ (~ selector) (~ g!fun) (~ g!record))))))) + + _ + (fail "Wrong syntax for update@"))) + +(macro: #export (^template tokens) + {#;doc "## It's similar to do-template, but meant to be used during pattern-matching. + (def: (beta-reduce env type) + (-> (List Type) Type Type) + (case type + (#;HostT name params) + (#;HostT name (List/map (beta-reduce env) params)) + + (^template [<tag>] + (<tag> left right) + (<tag> (beta-reduce env left) (beta-reduce env right))) + ([#;SumT] [#;ProdT]) + + (^template [<tag>] + (<tag> left right) + (<tag> (beta-reduce env left) (beta-reduce env right))) + ([#;LambdaT] + [#;AppT]) + + (^template [<tag>] + (<tag> old-env def) + (case old-env + #;Nil + (<tag> env def) + + _ + type)) + ([#;UnivQ] + [#;ExQ]) + + (#;BoundT idx) + (default type (list;at idx env)) + + (#;NamedT name type) + (beta-reduce env type) + + _ + type + ))"} + (case tokens + (^ (list& [_ (#FormS (list& [_ (#TupleS bindings)] templates))] + [_ (#FormS data)] + branches)) + (case (: (Maybe (List AST)) + (do Monad<Maybe> + [bindings' (mapM Monad<Maybe> get-name bindings) + data' (mapM Monad<Maybe> tuple->list data)] + (if (every? (i= (length bindings')) (map length data')) + (let [apply (: (-> RepEnv (List AST)) + (lambda [env] (map (apply-template env) templates)))] + (|> data' + (join-map (. apply (make-env bindings'))) + wrap)) + #;None))) + (#Some output) + (return (List/append output branches)) + + #None + (fail "Wrong syntax for ^template")) + + _ + (fail "Wrong syntax for ^template"))) + +(do-template [<name> <from> <to> <converter>] + [(def: #export (<name> n) + (-> <from> <to>) + (_lux_proc ["jvm" <converter>] [n]))] + + [real-to-int Real Int "d2l"] + [int-to-real Int Real "l2d"] + ) + +(do-template [<type> <category> <=-name> <=> <lt-name> <lte-name> <lt> <gt-name> <gte-name> + <eq-doc> <<-doc> <<=-doc> <>-doc> <>=-doc>] + [(def: #export (<=-name> test subject) + {#;doc <eq-doc>} + (-> <type> <type> Bool) + (_lux_proc [<category> <=>] [subject test])) + + (def: #export (<lt-name> test subject) + {#;doc <<-doc>} + (-> <type> <type> Bool) + (_lux_proc [<category> <lt>] [subject test])) + + (def: #export (<lte-name> test subject) + {#;doc <<=-doc>} + (-> <type> <type> Bool) + (or (_lux_proc [<category> <lt>] [subject test]) + (_lux_proc [<category> <=>] [subject test]))) + + (def: #export (<gt-name> test subject) + {#;doc <>-doc>} + (-> <type> <type> Bool) + (_lux_proc [<category> <lt>] [test subject])) + + (def: #export (<gte-name> test subject) + {#;doc <>=-doc>} + (-> <type> <type> Bool) + (or (_lux_proc [<category> <lt>] [test subject]) + (_lux_proc [<category> <=>] [subject test])))] + + [ Nat "nat" =+ "=" <+ <=+ "<" >+ >=+ + "Natural equality." "Natural less-than." "Natural less-than-equal." "Natural greater-than." "Natural greater-than-equal."] + + [ Int "jvm" = "leq" < <= "llt" > >= + "Integer equality." "Integer less-than." "Integer less-than-equal." "Integer greater-than." "Integer greater-than-equal."] + + [Frac "frac" =.. "=" <.. <=.. "<" >.. >=.. + "Fractional equality." "Fractional less-than." "Fractional less-than-equal." "Fractional greater-than." "Fractional greater-than-equal."] + + [Real "jvm" =. "deq" <. <=. "dlt" >. >=. + "Real equality." "Real less-than." "Real less-than-equal." "Real greater-than." "Real greater-than-equal."] + ) + +(do-template [<type> <name> <op> <doc>] + [(def: #export (<name> param subject) + {#;doc <doc>} + (-> <type> <type> <type>) + (_lux_proc <op> [subject param]))] + + [ Nat ++ ["nat" "+"] "Nat(ural) addition."] + [ Nat -+ ["nat" "-"] "Nat(ural) substraction."] + [ Nat *+ ["nat" "*"] "Nat(ural) multiplication."] + [ Nat /+ ["nat" "/"] "Nat(ural) division."] + [ Nat %+ ["nat" "%"] "Nat(ural) remainder."] + + [ Int + ["jvm" "ladd"] "Int(eger) addition."] + [ Int - ["jvm" "lsub"] "Int(eger) substraction."] + [ Int * ["jvm" "lmul"] "Int(eger) multiplication."] + [ Int / ["jvm" "ldiv"] "Int(eger) division."] + [ Int % ["jvm" "lrem"] "Int(eger) remainder."] + + [Frac +.. ["frac" "+"] "Frac(tional) addition."] + [Frac -.. ["frac" "-"] "Frac(tional) substraction."] + [Frac *.. ["frac" "*"] "Frac(tional) multiplication."] + [Frac /.. ["frac" "/"] "Frac(tional) division."] + [Frac %.. ["frac" "%"] "Frac(tional) remainder."] + + [Real +. ["jvm" "dadd"] "Real addition."] + [Real -. ["jvm" "dsub"] "Real substraction."] + [Real *. ["jvm" "dmul"] "Real multiplication."] + [Real /. ["jvm" "ddiv"] "Real division."] + [Real %. ["jvm" "drem"] "Real remainder."] + ) + +(do-template [<name> <type> <test> <doc>] + [(def: #export (<name> left right) + {#;doc <doc>} + (-> <type> <type> <type>) + (if (<test> right left) + left + right))] + + [min+ Nat <+ "Nat(ural) minimum."] + [max+ Nat >+ "Nat(ural) maximum."] + + [min Int < "Int(eger) minimum."] + [max Int > "Int(eger) maximum."] + + [min.. Frac <.. "Frac(tional) minimum."] + [max.. Frac >.. "Frac(tional) maximum."] + + [min. Real <. "Real minimum."] + [max. Real >. "Real minimum."] + ) + +(def: (find-baseline-column ast) + (-> AST Int) + (case ast + (^template [<tag>] + [[_ _ column] (<tag> _)] + column) + ([#BoolS] + [#NatS] + [#IntS] + [#FracS] + [#RealS] + [#CharS] + [#TextS] + [#SymbolS] + [#TagS]) + + (^template [<tag>] + [[_ _ column] (<tag> parts)] + (fold min column (map find-baseline-column parts))) + ([#FormS] + [#TupleS]) + + [[_ _ column] (#RecordS pairs)] + (fold min column + (List/append (map (. find-baseline-column first) pairs) + (map (. find-baseline-column second) pairs))) + )) + +(type: Doc-Fragment + (#Doc-Comment Text) + (#Doc-Example AST)) + +(def: (identify-doc-fragment ast) + (-> AST Doc-Fragment) + (case ast + [_ (#;TextS comment)] + (#Doc-Comment comment) + + _ + (#Doc-Example ast))) + +(def: (Char/encode x) + (-> Char Text) + (let [as-text (case x + #"\t" "\\t" + #"\b" "\\b" + #"\n" "\\n" + #"\r" "\\r" + #"\f" "\\f" + #"\"" "\\\"" + #"\\" "\\\\" + _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))] + ($_ Text/append "#\"" as-text "\""))) + +(def: (Text/encode original) + (-> Text Text) + (let [escaped (|> original + (replace "\t" "\\t") + (replace "\b" "\\b") + (replace "\n" "\\n") + (replace "\r" "\\r") + (replace "\f" "\\f") + (replace "\"" "\\\"") + (replace "\\" "\\\\") + )] + ($_ Text/append "\"" escaped "\""))) + +(do-template [<name> <diff>] + [(def: #export <name> + (-> Int Int) + (i+ <diff>))] + + [inc 1] + [dec -1]) + +(def: tag->Text + (-> Ident Text) + (. (Text/append "#") Ident->Text)) + +(def: (repeat n x) + (All [a] (-> Int a (List a))) + (if (i> n 0) + (#;Cons x (repeat (i+ -1 n) x)) + #;Nil)) + +(def: (cursor-padding baseline [_ old-line old-column] [_ new-line new-column]) + (-> Int Cursor Cursor Text) + (if (i= old-line new-line) + (Text/join (repeat (i- new-column old-column) " ")) + (let [extra-lines (Text/join (repeat (i- new-line old-line) "\n")) + space-padding (Text/join (repeat (i- new-column baseline) " "))] + (Text/append extra-lines space-padding)))) + +(def: (Text/size x) + (-> Text Int) + (_lux_proc ["jvm" "i2l"] + [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])])) + +(def: (Text/trim x) + (-> Text Text) + (_lux_proc ["jvm" "invokevirtual:java.lang.String:trim:"] [x])) + +(def: (update-cursor [file line column] ast-text) + (-> Cursor Text Cursor) + [file line (i+ column (Text/size ast-text))]) + +(def: (delim-update-cursor [file line column]) + (-> Cursor Cursor) + [file line (inc column)]) + +(def: rejoin-all-pairs + (-> (List [AST AST]) (List AST)) + (. List/join (map rejoin-pair))) + +(def: (doc-example->Text prev-cursor baseline example) + (-> Cursor Int AST [Cursor Text]) + (case example + (^template [<tag> <show>] + [new-cursor (<tag> value)] + (let [as-text (<show> value)] + [(update-cursor new-cursor as-text) + (Text/append (cursor-padding baseline prev-cursor new-cursor) + as-text)])) + ([#BoolS ->Text] + [#NatS Nat->Text] + [#IntS ->Text] + [#FracS Frac->Text] + [#RealS ->Text] + [#CharS Char/encode] + [#TextS Text/encode] + [#SymbolS Ident->Text] + [#TagS tag->Text]) + + (^template [<tag> <open> <close> <prep>] + [group-cursor (<tag> parts)] + (let [[group-cursor' parts-text] (fold (lambda [part [last-cursor text-accum]] + (let [[part-cursor part-text] (doc-example->Text last-cursor baseline part)] + [part-cursor (Text/append text-accum part-text)])) + [(delim-update-cursor group-cursor) ""] + (<prep> parts))] + [(delim-update-cursor group-cursor') + ($_ Text/append (cursor-padding baseline prev-cursor group-cursor) + <open> + parts-text + <close>)])) + ([#FormS "(" ")" id] + [#TupleS "[" "]" id] + [#RecordS "{" "}" rejoin-all-pairs]) + )) + +(def: (with-baseline baseline [file line column]) + (-> Int Cursor Cursor) + [file line baseline]) + +(def: (doc-fragment->Text fragment) + (-> Doc-Fragment Text) + (case fragment + (#Doc-Comment comment) + (|> comment + (split-text "\n") + (map (lambda [line] ($_ Text/append "## " line "\n"))) + Text/join) + + (#Doc-Example example) + (let [baseline (find-baseline-column example) + [cursor _] example + [_ text] (doc-example->Text (with-baseline baseline cursor) baseline example)] + (Text/append text "\n\n")))) + +(macro: #export (doc tokens) + {#;doc "Creates code documentation, embedding text as comments and properly formatting the forms it's being given. + + ## For Example: + (doc + \"Allows arbitrary looping, using the \\\"recur\\\" form to re-start the loop. + Can be used in monadic code to create monadic loops.\" + (loop [count 0 + x init] + (if (< 10 count) + (recur (inc count) (f x)) + x)))"} + (return (list (` (#;TextM (~ (|> tokens + (map (. doc-fragment->Text identify-doc-fragment)) + Text/join + Text/trim + text$))))))) + +(def: (interleave xs ys) + (All [a] (-> (List a) (List a) (List a))) + (case xs + #Nil + #Nil + + (#Cons x xs') + (case ys + #Nil + #Nil + + (#Cons y ys') + (list& x y (interleave xs' ys'))))) + +(def: (type->ast type) + (-> Type AST) + (case type + (#HostT name params) + (` (#HostT (~ (text$ name)) (~ (untemplate-list (map type->ast params))))) + + #VoidT + (` #VoidT) + + #UnitT + (` #UnitT) + + (^template [<tag>] + (<tag> left right) + (` (<tag> (~ (type->ast left)) (~ (type->ast right))))) + ([#SumT] [#ProdT]) + + (#LambdaT in out) + (` (#LambdaT (~ (type->ast in)) (~ (type->ast out)))) + + (#BoundT idx) + (` (#BoundT (~ (nat$ idx)))) + + (#VarT id) + (` (#VarT (~ (nat$ id)))) + + (#ExT id) + (` (#ExT (~ (nat$ id)))) + + (#UnivQ env type) + (let [env' (untemplate-list (map type->ast env))] + (` (#UnivQ (~ env') (~ (type->ast type))))) + + (#ExQ env type) + (let [env' (untemplate-list (map type->ast env))] + (` (#ExQ (~ env') (~ (type->ast type))))) + + (#AppT fun arg) + (` (#AppT (~ (type->ast fun)) (~ (type->ast arg)))) + + (#NamedT [module name] type) + (` (#NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type->ast type)))) + )) + +(macro: #export (loop tokens) + {#;doc (doc "Allows arbitrary looping, using the \"recur\" form to re-start the loop." + "Can be used in monadic code to create monadic loops." + (loop [count 0 + x init] + (if (< 10 count) + (recur (inc count) (f x)) + x)))} + (case tokens + (^ (list [_ (#TupleS bindings)] body)) + (let [pairs (as-pairs bindings) + vars (map first pairs) + inits (map second pairs)] + (if (every? symbol? inits) + (do Monad<Lux> + [inits' (: (Lux (List Ident)) + (case (mapM Monad<Maybe> get-ident inits) + (#Some inits') (return inits') + #None (fail "Wrong syntax for loop"))) + init-types (mapM Monad<Lux> find-type inits') + expected get-expected-type] + (return (list (` ((;_lux_: (-> (~@ (map type->ast init-types)) + (~ (type->ast expected))) + (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)] + (~ body))) + (~@ inits)))))) + (do Monad<Lux> + [aliases (mapM Monad<Lux> + (: (-> AST (Lux AST)) + (lambda [_] (gensym ""))) + inits)] + (return (list (` (let [(~@ (interleave aliases inits))] + (;loop [(~@ (interleave vars aliases))] + (~ body))))))))) + + _ + (fail "Wrong syntax for loop"))) + +(macro: #export (^slots tokens) + {#;doc (doc "Allows you to extract record members as local variables with the same names." + "For example:" + (let [(^slots [#foo #bar #baz]) quux] + (f foo bar baz)))} + (case tokens + (^ (list& [_ (#FormS (list [_ (#TupleS (list& hslot' tslots'))]))] body branches)) + (do Monad<Lux> + [slots (: (Lux [Ident (List Ident)]) + (case (: (Maybe [Ident (List Ident)]) + (do Monad<Maybe> + [hslot (get-tag hslot') + tslots (mapM Monad<Maybe> get-tag tslots')] + (wrap [hslot tslots]))) + (#Some slots) + (return slots) + + #None + (fail "Wrong syntax for ^slots"))) + #let [[hslot tslots] slots] + hslot (normalize hslot) + tslots (mapM Monad<Lux> normalize tslots) + output (resolve-tag hslot) + g!_ (gensym "_") + #let [[idx tags exported? type] output + slot-pairings (map (: (-> Ident [Text AST]) + (lambda [[module name]] [name (symbol$ ["" name])])) + (list& hslot tslots)) + pattern (record$ (map (: (-> Ident [AST AST]) + (lambda [[module name]] + (let [tag (tag$ [module name])] + (case (get name slot-pairings) + (#Some binding) [tag binding] + #None [tag g!_])))) + tags))]] + (return (list& pattern body branches))) + + _ + (fail "Wrong syntax for ^slots"))) + +(def: (place-tokens label tokens target) + (-> Text (List AST) AST (Maybe (List AST))) + (case target + (^or [_ (#BoolS _)] [_ (#NatS _)] [_ (#IntS _)] [_ (#FracS _)] [_ (#RealS _)] [_ (#CharS _)] [_ (#TextS _)] [_ (#TagS _)]) + (#Some (list target)) + + [_ (#SymbolS [prefix name])] + (if (and (Text/= "" prefix) + (Text/= label name)) + (#Some tokens) + (#Some (list target))) + + (^template [<tag> <ctor>] + [_ (<tag> elems)] + (do Monad<Maybe> + [placements (mapM Monad<Maybe> (place-tokens label tokens) elems)] + (wrap (list (<ctor> (List/join placements)))))) + ([#TupleS tuple$] + [#FormS form$]) + + [_ (#RecordS pairs)] + (do Monad<Maybe> + [=pairs (mapM Monad<Maybe> + (: (-> [AST AST] (Maybe [AST AST])) + (lambda [[slot value]] + (do Monad<Maybe> + [slot' (place-tokens label tokens slot) + value' (place-tokens label tokens value)] + (case [slot' value'] + (^ [(list =slot) (list =value)]) + (wrap [=slot =value]) + + _ + #None)))) + pairs)] + (wrap (list (record$ =pairs)))) + )) + +(macro: #export (let% tokens) + {#;doc (doc "Controlled macro-expansion." + "Bind an arbitraty number of ASTs resulting from macro-expansion to local bindings." + "Wherever a binding appears, the bound ASTs will be spliced in there." + (test: "AST operations & structures" + (let% [<tests> (do-template [<expr> <text> <pattern>] + [(compare <pattern> <expr>) + (compare <text> (:: AST/Show show <expr>)) + (compare true (:: Eq<AST> = <expr> <expr>))] + + [(bool true) "true" [["" -1 -1] (#;BoolS true)]] + [(bool false) "false" [_ (#;BoolS false)]] + [(int 123) "123" [_ (#;IntS 123)]] + [(real 123.0) "123.0" [_ (#;RealS 123.0)]] + [(char #"\n") "#\"\\n\"" [_ (#;CharS #"\n")]] + [(text "\n") "\"\\n\"" [_ (#;TextS "\n")]] + [(tag ["yolo" "lol"]) "#yolo;lol" [_ (#;TagS ["yolo" "lol"])]] + [(symbol ["yolo" "lol"]) "yolo;lol" [_ (#;SymbolS ["yolo" "lol"])]] + [(form (list (bool true) (int 123))) "(true 123)" (^ [_ (#;FormS (list [_ (#;BoolS true)] [_ (#;IntS 123)]))])] + [(tuple (list (bool true) (int 123))) "[true 123]" (^ [_ (#;TupleS (list [_ (#;BoolS true)] [_ (#;IntS 123)]))])] + [(record (list [(bool true) (int 123)])) "{true 123}" (^ [_ (#;RecordS (list [[_ (#;BoolS true)] [_ (#;IntS 123)]]))])] + [(local-tag "lol") "#lol" [_ (#;TagS ["" "lol"])]] + [(local-symbol "lol") "lol" [_ (#;SymbolS ["" "lol"])]] + )] + (test-all <tests>))))} + (case tokens + (^ (list& [_ (#TupleS bindings)] bodies)) + (case bindings + (^ (list& [_ (#SymbolS ["" var-name])] macro-expr bindings')) + (do Monad<Lux> + [expansion (macro-expand-once macro-expr)] + (case (place-tokens var-name expansion (` (;let% [(~@ bindings')] (~@ bodies)))) + (#Some output) + (wrap output) + + _ + (fail "[let%] Improper macro expansion."))) + + #Nil + (return bodies) + + _ + (fail "Wrong syntax for let%")) + + _ + (fail "Wrong syntax for let%"))) + +(def: (flatten-alias type) + (-> Type Type) + (case type + (^template [<name>] + (#NamedT ["lux" <name>] _) + type) + (["Bool"] + ["Nat"] + ["Int"] + ["Frac"] + ["Real"] + ["Char"] + ["Text"]) + + (#NamedT _ type') + type' + + _ + type)) + +(def: (anti-quote-def name) + (-> Ident (Lux AST)) + (do Monad<Lux> + [type+value (find-def-value name) + #let [[type value] type+value]] + (case (flatten-alias type) + (^template [<name> <type> <wrapper>] + (#NamedT ["lux" <name>] _) + (wrap (<wrapper> (:! <type> value)))) + (["Bool" Bool bool$] + ["Nat" Nat nat$] + ["Int" Int int$] + ["Frac" Frac frac$] + ["Real" Real real$] + ["Char" Char char$] + ["Text" Text text$]) + + _ + (fail (Text/append "Can't anti-quote type: " (Ident->Text name)))))) + +(def: (anti-quote token) + (-> AST (Lux AST)) + (case token + [_ (#SymbolS [def-prefix def-name])] + (if (Text/= "" def-prefix) + (:: Monad<Lux> return token) + (anti-quote-def [def-prefix def-name])) + + (^template [<tag>] + [meta (<tag> parts)] + (do Monad<Lux> + [=parts (mapM Monad<Lux> anti-quote parts)] + (wrap [meta (<tag> =parts)]))) + ([#FormS] + [#TupleS]) + + [meta (#RecordS pairs)] + (do Monad<Lux> + [=pairs (mapM Monad<Lux> + (: (-> [AST AST] (Lux [AST AST])) + (lambda [[slot value]] + (do Monad<Lux> + [=value (anti-quote value)] + (wrap [slot =value])))) + pairs)] + (wrap [meta (#RecordS =pairs)])) + + _ + (:: Monad<Lux> return token) + )) + +(macro: #export (^~ tokens) + {#;doc (doc "Use global defs with simple values, such as text, int, real, bool and char, in place of literals in patterns." + "The definitions must be properly-qualified (though you may use one of the short-cuts Lux provides)." + (def: (empty?' node) + (All [K V] (-> (Node K V) Bool)) + (case node + (^~ (#Base ;;clean-bitmap _)) + true + + _ + false)))} + (case tokens + (^ (list& [_ (#FormS (list pattern))] body branches)) + (do Monad<Lux> + [module-name current-module-name + pattern+ (macro-expand-all pattern)] + (case pattern+ + (^ (list pattern')) + (do Monad<Lux> + [pattern'' (anti-quote pattern')] + (wrap (list& pattern'' body branches))) + + _ + (fail "^~ can only expand to 1 pattern."))) + + _ + (fail "Wrong syntax for ^~"))) + +(type: MultiLevelCase + [AST (List [AST AST])]) + +(def: (case-level^ level) + (-> AST (Lux [AST AST])) + (case level + (^ [_ (#;RecordS (list [expr binding]))]) + (return [expr binding]) + + _ + (return [level (` true)]) + )) + +(def: (multi-level-case^ levels) + (-> (List AST) (Lux MultiLevelCase)) + (case levels + #;Nil + (fail "Multi-level patterns can't be empty.") + + (#;Cons init extras) + (do Monad<Lux> + [extras' (mapM Monad<Lux> case-level^ extras)] + (wrap [init extras'])))) + +(def: (multi-level-case$ g!_ [[init-pattern levels] body]) + (-> AST [MultiLevelCase AST] (List AST)) + (let [inner-pattern-body (fold (lambda [[calculation pattern] success] + (` (case (~ calculation) + (~ pattern) + (~ success) + + (~ g!_) + #;None))) + (` (#;Some (~ body))) + (: (List [AST AST]) (reverse levels)))] + (list init-pattern inner-pattern-body))) + +(macro: #export (^=> tokens) + {#;doc (doc "Multi-level pattern matching." + "Useful in situations where the result of a branch depends on further refinements on the values being matched." + "For example:" + (case (split (size static) uri) + (^=> (#;Some [chunk uri']) {(Text/= static chunk) true}) + (match-uri endpoint? parts' uri') + + _ + (#;Left (format "Static part " (%t static) " doesn't match URI: " uri))) + + "Short-cuts can be taken when using boolean tests." + "The example above can be rewritten as..." + (case (split (size static) uri) + (^=> (#;Some [chunk uri']) (Text/= static chunk)) + (match-uri endpoint? parts' uri') + + _ + (#;Left (format "Static part " (%t static) " doesn't match URI: " uri))))} + (case tokens + (^ (list& [_meta (#;FormS levels)] body next-branches)) + (do Monad<Lux> + [mlc (multi-level-case^ levels) + expected get-expected-type + g!temp (gensym "temp")] + (let [output (list g!temp + (` (;_lux_case (;_lux_: (#;AppT Maybe (~ (type->ast expected))) + (case (~ g!temp) + (~@ (multi-level-case$ g!temp [mlc body])) + + (~ g!temp) + #;None)) + (#;Some (~ g!temp)) + (~ g!temp) + + #;None + (case (~ g!temp) + (~@ next-branches)))))] + (wrap output))) + + _ + (fail "Wrong syntax for ^=>"))) + +(macro: #export (ident-for tokens) + {#;doc (doc "Given a symbol or a tag, gives back a 2 tuple with the prefix and name parts, both as Text." + (ident-for #;doc) + "=>" + ["lux" "doc"])} + (case tokens + (^template [<tag>] + (^ (list [_ (<tag> [prefix name])])) + (return (list (` [(~ (text$ prefix)) (~ (text$ name))])))) + ([#;SymbolS] [#;TagS]) + + _ + (fail "Wrong syntax for ident-for"))) + +(do-template [<type> <even> <odd> <%> <=> <0> <2>] + [(def: #export (<even> n) + (-> <type> Bool) + (<=> <0> (<%> n <2>))) + + (def: #export (<odd> n) + (-> <type> Bool) + (not (<even> n)))] + + [Nat even?+ odd?+ n% n= +0 +2] + [Int even? odd? i% i= 0 2]) + +(def: (get-scope-type-vars state) + (Lux (List Nat)) + (case state + {#info info #source source #modules modules + #scopes scopes #type-vars types #host host + #seed seed #expected expected #cursor cursor + #scope-type-vars scope-type-vars} + (#Right state scope-type-vars) + )) + +(def: (list-at idx xs) + (All [a] (-> Int (List a) (Maybe a))) + (case xs + #;Nil + #;None + + (#;Cons x xs') + (if (i= 0 idx) + (#;Some x) + (list-at (dec idx) xs')))) + +(macro: #export ($ tokens) + (case tokens + (^ (list [_ (#IntS idx)])) + (do Monad<Lux> + [stvs get-scope-type-vars] + (case (list-at idx (reverse stvs)) + (#;Some var-id) + (wrap (list (` (#ExT (~ (nat$ var-id)))))) + + #;None + (fail (Text/append "Indexed-type doesn't exist: " (->Text idx))))) + + _ + (fail "Wrong syntax for $"))) + +(def: #export (== left right) + {#;doc (doc "Tests whether the 2 values are identical (not just \"equal\")." + "This one should succeed:" + (let [value 5] + (== 5 5)) + + "This one should fail:" + (== 5 (+ 2 3)))} + (All [a] (-> a a Bool)) + (_lux_proc ["lux" "=="] [left right])) + +(macro: #export (^@ tokens) + {#;doc (doc "Allows you to simultaneously bind and de-structure a value." + (def: (hash (^@ set [a/Hash _])) + (List/fold (lambda [elem acc] (+ (:: a/Hash hash elem) acc)) + 0 + (->List set))))} + (case tokens + (^ (list& [_meta (#;FormS (list [_ (#;SymbolS ["" name])] pattern))] body branches)) + (let [g!whole (symbol$ ["" name])] + (return (list& g!whole + (` (case (~ g!whole) (~ pattern) (~ body))) + branches))) + + _ + (fail "Wrong syntax for ^@"))) + +(macro: #export (^|> tokens) + (case tokens + (^ (list& [_meta (#;FormS (list [_ (#;SymbolS ["" name])] [_ (#;TupleS steps)]))] body branches)) + (let [g!name (symbol$ ["" name])] + (return (list& g!name + (` (let [(~ g!name) (|> (~ g!name) (~@ steps))] + (~ body))) + branches))) + + _ + (fail "Wrong syntax for ^|>"))) + +(macro: #export (:!! tokens) + {#;doc (doc "Coerces the given expression to the type of whatever is expected." + (: Dinosaur (:!! (list 1 2 3))))} + (case tokens + (^ (list expr)) + (do Monad<Lux> + [type get-expected-type] + (wrap (list (` (;_lux_:! (~ (type->ast type)) (~ expr)))))) + + _ + (fail "Wrong syntax for :!!"))) + +(def: #export (error! message) + {#;doc (doc "Causes an error, with the given error message." + (error! "OH NO!"))} + (-> Text Bottom) + (_lux_proc ["jvm" "throw"] [(_lux_proc ["jvm" "new:java.lang.Error:java.lang.String"] [message])])) + +(def: #hidden hack_Text/append + (-> Text Text Text) + Text/append) + +(def: get-cursor + (Lux Cursor) + (lambda [state] + (let [{#;info info #;source source #;modules modules #;scopes scopes + #;type-vars types #;host host #;seed seed + #;expected expected #;cursor cursor + #;scope-type-vars scope-type-vars} state] + (#;Right [state cursor])))) + +(macro: #export (with-cursor tokens) + {#;doc (doc "Given some text, appends to it a prefix for identifying where the text comes from." + "For example:" + (with-cursor (format "User: " user-id)) + "Would be the same as:" + (format "[the-module,the-line,the-column] " (format "User: " user-id)))} + (case tokens + (^ (list message)) + (do Monad<Lux> + [cursor get-cursor] + (let [[module line column] cursor + cursor-prefix ($_ hack_Text/append "[" module "," (->Text line) "," (->Text column) "] ")] + (wrap (list (` (hack_Text/append (~ (text$ cursor-prefix)) (~ message))))))) + + _ + (fail "Wrong syntax for @"))) + +(macro: #export (undefined tokens) + {#;doc (doc "Meant to be used as a stand-in for functions with undefined implementations." + (def: (square x) + (-> Int Int) + (undefined)))} + (case tokens + #;Nil + (return (list (` (error! (with-cursor "Undefined behavior."))))) + + _ + (fail "Wrong syntax for undefined"))) + +(macro: #export (@pre tokens) + (case tokens + (^ (list test expr)) + (return (list (` (if (~ test) + (~ expr) + (error! (with-cursor (~ (text$ (Text/append "Pre-condition failed: " (ast-to-text test)))))))))) + + _ + (fail "Wrong syntax for @pre"))) + +(macro: #export (@post tokens) + (case tokens + (^ (list test pattern expr)) + (do Monad<Lux> + [g!output (gensym "") + exp-type get-expected-type] + (wrap (list (` (let [(~ g!output) (: (~ (type->ast exp-type)) (~ expr)) + (~ pattern) (~ g!output)] + (if (~ test) + (~ g!output) + (error! (with-cursor (~ (text$ (Text/append "Post-condition failed: " (ast-to-text test)))))))))))) + + _ + (fail "Wrong syntax for @post"))) + +(do-template [<name> <op> <from> <to>] + [(def: #export (<name> input) + (-> <from> <to>) + (_lux_proc <op> [input]))] + + [int-to-nat ["int" "to-nat"] Int Nat] + [nat-to-int ["nat" "to-int"] Nat Int] + + [real-to-frac ["real" "to-frac"] Real Frac] + [frac-to-real ["frac" "to-real"] Frac Real] + ) + +(do-template [<name> <op>] + [(def: #export <name> + (-> Nat Nat) + (<op> +1))] + + [inc+ ++] + [dec+ -+]) diff --git a/stdlib/source/lux/cli.lux b/stdlib/source/lux/cli.lux new file mode 100644 index 000000000..d9039df13 --- /dev/null +++ b/stdlib/source/lux/cli.lux @@ -0,0 +1,271 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + [lux #- not] + (lux (control functor + applicative + monad) + (data (struct (list #as list #open ("List/" Monoid<List> Monad<List>))) + (text #as text #open ("Text/" Monoid<Text>)) + error + (sum #as sum)) + (codata [io]) + [compiler #+ with-gensyms Functor<Lux> Monad<Lux>] + (macro [ast] + ["s" syntax #+ syntax: Syntax]))) + +## [Types] +(type: #export (CLI a) + (-> (List Text) (Error [(List Text) a]))) + +## [Utils] +(def: (run' opt inputs) + (All [a] (-> (CLI a) (List Text) (Error [(List Text) a]))) + (opt inputs)) + +## [Structures] +(struct: #export _ (Functor CLI) + (def: (map f ma inputs) + (case (ma inputs) + (#;Left msg) (#;Left msg) + (#;Right [inputs' datum]) (#;Right [inputs' (f datum)])))) + +(struct: #export _ (Applicative CLI) + (def: functor Functor<CLI>) + + (def: (wrap a inputs) + (#;Right [inputs a])) + + (def: (apply ff fa inputs) + (case (ff inputs) + (#;Right [inputs' f]) + (case (fa inputs') + (#;Right [inputs'' a]) + (#;Right [inputs'' (f a)]) + + (#;Left msg) + (#;Left msg)) + + (#;Left msg) + (#;Left msg)) + )) + +(struct: #export _ (Monad CLI) + (def: applicative Applicative<CLI>) + + (def: (join mma inputs) + (case (mma inputs) + (#;Left msg) (#;Left msg) + (#;Right [inputs' ma]) (ma inputs')))) + +## [Combinators] +(def: #export any + {#;doc "Just returns the next input without applying any logic."} + (CLI Text) + (lambda [inputs] + (case inputs + (#;Cons arg inputs') + (#;Right [inputs' arg]) + + _ + (#;Left "Can't extract from empty arguments.")))) + +(def: #export (parse parser option) + {#;doc "Parses the next input with a parsing function."} + (All [a] (-> (-> Text (Error a)) (CLI Text) (CLI a))) + (lambda [inputs] + (case (option inputs) + (#;Right [inputs' input]) + (case (parser input) + (#;Right value) + (#;Right [inputs' value]) + + (#;Left parser-error) + (#;Left parser-error)) + + (#;Left option-error) + (#;Left option-error) + ))) + +(def: #export (option names) + {#;doc "Checks that a given option (with multiple possible names) has a value."} + (-> (List Text) (CLI Text)) + (lambda [inputs] + (let [[pre post] (list;split-with (. ;not (list;member? text;Eq<Text> names)) inputs)] + (case post + #;Nil + (#;Left ($_ Text/append "Missing option (" (text;join-with " " names) ")")) + + (^ (list& _ value post')) + (#;Right [(List/append pre post') value]) + + _ + (#;Left ($_ Text/append "Option lacks value (" (text;join-with " " names) ")")) + )))) + +(def: #export (flag names) + {#;doc "Checks that a given flag (with multiple possible names) is set."} + (-> (List Text) (CLI Bool)) + (lambda [inputs] + (let [[pre post] (list;split-with (. ;not (list;member? text;Eq<Text> names)) inputs)] + (case post + #;Nil + (#;Right [pre false]) + + (#;Cons _ post') + (#;Right [(List/append pre post') true]))))) + +(def: #export end + {#;doc "Ensures there are no more inputs."} + (CLI Unit) + (lambda [inputs] + (case inputs + #;Nil (#;Right [inputs []]) + _ (#;Left (Text/append "Unknown parameters: " (text;join-with " " inputs)))))) + +(def: #export (assert test message) + (-> Bool Text (CLI Unit)) + (lambda [inputs] + (if test + (#;Right [inputs []]) + (#;Left message)))) + +(def: #export (opt opt) + {#;doc "Optionality combinator."} + (All [a] + (-> (CLI a) (CLI (Maybe a)))) + (lambda [inputs] + (case (opt inputs) + (#;Left _) (#;Right [inputs #;None]) + (#;Right [inputs' x]) (#;Right [inputs' (#;Some x)])))) + +(def: #export (seq optL optR) + {#;doc "Sequencing combinator."} + (All [a b] (-> (CLI a) (CLI b) (CLI [a b]))) + (do Monad<CLI> + [l optL + r optR] + (wrap [l r]))) + +(def: #export (alt optL optR) + {#;doc "Heterogeneous alternative combinator."} + (All [a b] (-> (CLI a) (CLI b) (CLI (| a b)))) + (lambda [inputs] + (case (optL inputs) + (#;Left msg) + (case (optR inputs) + (#;Left _) + (#;Left msg) + + (#;Right [inputs' r]) + (#;Right [inputs' (sum;right r)])) + + (#;Right [inputs' l]) + (#;Right [inputs' (sum;left l)])))) + +(def: #export (not opt) + (All [a] (-> (CLI a) (CLI Unit))) + (lambda [inputs] + (case (opt inputs) + (#;Left msg) + (#;Right [inputs []]) + + _ + (#;Left "Expected to fail; yet succeeded.")))) + +(def: #export (some opt) + {#;doc "0-or-more combinator."} + (All [a] + (-> (CLI a) (CLI (List a)))) + (lambda [inputs] + (case (opt inputs) + (#;Left _) (#;Right [inputs (list)]) + (#;Right [inputs' x]) (run' (do Monad<CLI> + [xs (some opt)] + (wrap (list& x xs))) + inputs')))) + +(def: #export (many opt) + {#;doc "1-or-more combinator."} + (All [a] + (-> (CLI a) (CLI (List a)))) + (do Monad<CLI> + [x opt + xs (some opt)] + (wrap (list& x xs)))) + +(def: #export (either pl pr) + {#;doc "Homogeneous alternative combinator."} + (All [a] + (-> (CLI a) (CLI a) (CLI a))) + (lambda [inputs] + (case (pl inputs) + (#;Left _) (pr inputs) + output output))) + +(def: #export (run opt inputs) + (All [a] (-> (CLI a) (List Text) (Error a))) + (case (opt inputs) + (#;Left msg) + (#;Left msg) + + (#;Right [_ value]) + (#;Right value))) + +## [Syntax] +(type: Program-Args + (#Raw-Program-Args Text) + (#Parsed-Program-Args (List [Text AST]))) + +(def: program-args^ + (Syntax Program-Args) + (s;alt s;local-symbol + (s;form (s;some (s;either (do s;Monad<Syntax> + [name s;local-symbol] + (wrap [name (` any)])) + (s;record (s;seq s;local-symbol s;any))))))) + +(syntax: #export (program: {args program-args^} body) + {#;doc (doc "Defines the entry-point to a program (similar to the \"main\" function/method in other programming languages)." + "Can take a list of all the input parameters to the program, or can destructure them using CLI-option combinators from the lux/cli module." + (program: all-args + (do Monad<IO> + [foo init-program + bar (do-something all-args)] + (wrap []))) + + (program: (name) + (io (log! (Text/append "Hello, " name)))) + + (program: ([config config^]) + (do Monad<IO> + [data (init-program config)] + (do-something data))))} + (case args + (#Raw-Program-Args args) + (wrap (list (` (;_lux_program (~ (ast;symbol ["" args])) + (~ body))))) + + (#Parsed-Program-Args args) + (with-gensyms [g!args g!_ g!output g!message] + (wrap (list (` (;_lux_program (~ g!args) + (case ((: (CLI (io;IO Unit)) + (do Monad<CLI> + [(~@ (|> args + (List/map (lambda [[name parser]] + (list (ast;symbol ["" name]) parser))) + List/join)) + (~ g!_) end] + ((~' wrap) (~ body)))) + (~ g!args)) + (#;Right [(~ g!_) (~ g!output)]) + (~ g!output) + + (#;Left (~ g!message)) + (error! (~ g!message)) + ))) + ))) + )) diff --git a/stdlib/source/lux/codata/cont.lux b/stdlib/source/lux/codata/cont.lux new file mode 100644 index 000000000..b851d417c --- /dev/null +++ b/stdlib/source/lux/codata/cont.lux @@ -0,0 +1,64 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (macro (ast #as ast)) + (control (functor #as F #refer #all) + (applicative #as A #refer #all) + (monad #as M #refer #all)) + (data (struct list))) + (.. function)) + +## [Types] +(type: #export (Cont a) + (All [b] + (-> (-> a b) b))) + +## [Syntax] +(macro: #export (@lazy tokens state) + {#;doc (doc "Delays the evaluation of an expression, by wrapping it in a continuation 'thunk'." + (@lazy (some-computation some-input)))} + (case tokens + (^ (list value)) + (let [blank (ast;symbol ["" ""])] + (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))])) + + _ + (#;Left "Wrong syntax for @lazy"))) + +## [Functions] +(def: #export (call/cc f) + {#;doc "Call with current continuation."} + (All [a b c] (Cont (-> a (Cont b c)) (Cont a c))) + (lambda [k] + (f (lambda [a _] + (k a)) + k))) + +(def: #export (run thunk) + {#;doc "Forces a continuation thunk to be evaluated."} + (All [a] + (-> (Cont a) a)) + (thunk id)) + +## [Structs] +(struct: #export _ (Functor Cont) + (def: (map f ma) + (lambda [k] (ma (. k f))))) + +(struct: #export _ (Applicative Cont) + (def: functor Functor<Cont>) + + (def: (wrap a) + (@lazy a)) + + (def: (apply ff fa) + (@lazy ((run ff) (run fa))))) + +(struct: #export _ (Monad Cont) + (def: applicative Applicative<Cont>) + + (def: join run)) diff --git a/stdlib/source/lux/codata/env.lux b/stdlib/source/lux/codata/env.lux new file mode 100644 index 000000000..8883b4a66 --- /dev/null +++ b/stdlib/source/lux/codata/env.lux @@ -0,0 +1,65 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + applicative + ["M" monad #*]))) + +## [Types] +(type: #export (Env r a) + (-> r a)) + +## [Structures] +(struct: #export Functor<Env> (All [r] (Functor (Env r))) + (def: (map f fa) + (lambda [env] + (f (fa env))))) + +(struct: #export Applicative<Env> (All [r] (Applicative (Env r))) + (def: functor Functor<Env>) + + (def: (wrap x) + (lambda [env] x)) + + (def: (apply ff fa) + (lambda [env] + ((ff env) (fa env))))) + +(struct: #export Monad<Env> (All [r] (Monad (Env r))) + (def: applicative Applicative<Env>) + + (def: (join mma) + (lambda [env] + (mma env env)))) + +## [Values] +(def: #export ask + {#;doc "Get the value of the environment."} + (All [r] (Env r r)) + (lambda [env] env)) + +(def: #export (local change env-proc) + {#;doc "Run computation with a locally-modified environment."} + (All [r a] (-> (-> r r) (Env r a) (Env r a))) + (|>. change env-proc)) + +(def: #export (run env env-proc) + (All [r a] (-> r (Env r a) a)) + (env-proc env)) + +(struct: #export (EnvT Monad<M>) + (All [M e] (-> (Monad M) (Monad (All [a] (Env e (M a)))))) + (def: applicative (compA Applicative<Env> (get@ #M;applicative Monad<M>))) + (def: (join eMeMa) + (lambda [env] + (do Monad<M> + [eMa (run env eMeMa)] + (run env eMa))))) + +(def: #export lift-env + (All [M e a] (-> (M a) (Env e (M a)))) + (:: Monad<Env> wrap)) diff --git a/stdlib/source/lux/codata/function.lux b/stdlib/source/lux/codata/function.lux new file mode 100644 index 000000000..fba5528a8 --- /dev/null +++ b/stdlib/source/lux/codata/function.lux @@ -0,0 +1,23 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monoid))) + +## [Functions] +(def: #export (const x y) + (All [a b] (-> a (-> b a))) + x) + +(def: #export (flip f) + (All [a b c] + (-> (-> a b c) (-> b a c))) + (lambda [x y] (f y x))) + +## [Structures] +(struct: #export Monoid<Function> (Monoid (All [a] (-> a a))) + (def: unit id) + (def: append .)) diff --git a/stdlib/source/lux/codata/io.lux b/stdlib/source/lux/codata/io.lux new file mode 100644 index 000000000..1398dfae5 --- /dev/null +++ b/stdlib/source/lux/codata/io.lux @@ -0,0 +1,56 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + applicative + monad) + (data (struct list)))) + +## [Types] +(type: #export (IO a) + (-> Void a)) + +## [Syntax] +(macro: #export (io tokens state) + {#;doc (doc + "Delays the evaluation of an expression, by wrapping it in an IO 'thunk'." + "Great for wrapping side-effecting computations (which won't be performed until the IO is \"run\")." + (io (exec + (log! msg) + "Some value...")))} + (case tokens + (^ (list value)) + (let [blank (: AST [["" -1 -1] (#;SymbolS ["" ""])])] + (#;Right [state (list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))])) + + _ + (#;Left "Wrong syntax for io"))) + +## [Structures] +(struct: #export _ (Functor IO) + (def: (map f ma) + (io (f (ma (:! Void [])))))) + +(struct: #export _ (Applicative IO) + (def: functor Functor<IO>) + + (def: (wrap x) + (io x)) + + (def: (apply ff fa) + (io ((ff (:! Void [])) (fa (:! Void [])))))) + +(struct: #export _ (Monad IO) + (def: applicative Applicative<IO>) + + (def: (join mma) + (io ((mma (:! Void [])) (:! Void []))))) + +## [Functions] +(def: #export (run action) + (All [a] (-> (IO a) a)) + (action (:! Void []))) diff --git a/stdlib/source/lux/codata/state.lux b/stdlib/source/lux/codata/state.lux new file mode 100644 index 000000000..82e9b40fd --- /dev/null +++ b/stdlib/source/lux/codata/state.lux @@ -0,0 +1,114 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + ["A" applicative #*] + ["M" monad #*]))) + +## [Types] +(type: #export (State s a) + (-> s [s a])) + +## [Structures] +(struct: #export Functor<State> (All [s] (Functor (State s))) + (def: (map f ma) + (lambda [state] + (let [[state' a] (ma state)] + [state' (f a)])))) + +(struct: #export Applicative<State> (All [s] (Applicative (State s))) + (def: functor Functor<State>) + + (def: (wrap a) + (lambda [state] + [state a])) + + (def: (apply ff fa) + (lambda [state] + (let [[state' f] (ff state) + [state'' a] (fa state')] + [state'' (f a)])))) + +(struct: #export Monad<State> (All [s] (Monad (State s))) + (def: applicative Applicative<State>) + + (def: (join mma) + (lambda [state] + (let [[state' ma] (mma state)] + (ma state'))))) + +## [Values] +(def: #export get + (All [s] (State s s)) + (lambda [state] + [state state])) + +(def: #export (put new-state) + (All [s] (-> s (State s Unit))) + (lambda [state] + [new-state []])) + +(def: #export (update change) + (All [s] (-> (-> s s) (State s Unit))) + (lambda [state] + [(change state) []])) + +(def: #export (use user) + {#;doc "Run function on current state."} + (All [s a] (-> (-> s a) (State s a))) + (lambda [state] + [state (user state)])) + +(def: #export (local change action) + {#;doc "Run computation with a locally-modified state."} + (All [s a] (-> (-> s s) (State s a) (State s a))) + (lambda [state] + (let [[state' output] (action (change state))] + [state output]))) + +(def: #export (run state action) + (All [s a] (-> s (State s a) [s a])) + (action state)) + +(struct: (Functor<StateT> Functor<M>) + (All [M s] (-> (Functor M) (Functor (All [a] (-> s (M [s a])))))) + (def: (map f sfa) + (lambda [state] + (:: Functor<M> map (lambda [[s a]] [s (f a)]) + (sfa state))))) + +(struct: (Applicative<StateT> Monad<M>) + (All [M s] (-> (Monad M) (Applicative (All [a] (-> s (M [s a])))))) + (def: functor (Functor<StateT> (get@ [#M;applicative #A;functor] + Monad<M>))) + + (def: (wrap a) + (lambda [state] + (:: Monad<M> wrap [state a]))) + + (def: (apply sFf sFa) + (lambda [state] + (do Monad<M> + [[state f] (sFf state) + [state a] (sFa state)] + (wrap [state (f a)]))))) + +(struct: #export (StateT Monad<M>) + (All [M s] (-> (Monad M) (Monad (All [a] (-> s (M [s a])))))) + (def: applicative (Applicative<StateT> Monad<M>)) + (def: (join sMsMa) + (lambda [state] + (do Monad<M> + [[state' sMa] (sMsMa state)] + (sMa state'))))) + +(def: #export (lift-state Monad<M> ma) + (All [M s a] (-> (Monad M) (M a) (-> s (M [s a])))) + (lambda [state] + (do Monad<M> + [a ma] + (wrap [state a])))) diff --git a/stdlib/source/lux/codata/struct/stream.lux b/stdlib/source/lux/codata/struct/stream.lux new file mode 100644 index 000000000..8814ec460 --- /dev/null +++ b/stdlib/source/lux/codata/struct/stream.lux @@ -0,0 +1,135 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + monad + comonad) + [compiler #+ with-gensyms] + (macro ["s" syntax #+ syntax: Syntax]) + (data (struct [list "List/" Monad<List>]) + bool) + (codata [cont #+ @lazy Cont]))) + +## [Types] +(type: #export (Stream a) + (Cont [a (Stream a)])) + +## [Utils] +(def: (cycle' x xs init full) + (All [a] + (-> a (List a) a (List a) (Stream a))) + (case xs + #;Nil (@lazy [x (cycle' init full init full)]) + (#;Cons x' xs') (@lazy [x (cycle' x' xs' init full)]))) + +## [Functions] +(def: #export (iterate f x) + (All [a] + (-> (-> a a) a (Stream a))) + (@lazy [x (iterate f (f x))])) + +(def: #export (repeat x) + (All [a] + (-> a (Stream a))) + (@lazy [x (repeat x)])) + +(def: #export (cycle xs) + (All [a] + (-> (List a) (Maybe (Stream a)))) + (case xs + #;Nil #;None + (#;Cons x xs') (#;Some (cycle' x xs' x xs')))) + +(do-template [<name> <return> <part>] + [(def: #export (<name> s) + (All [a] (-> (Stream a) <return>)) + (let [[h t] (cont;run s)] + <part>))] + + [head a h] + [tail (Stream a) t]) + +(def: #export (at idx s) + (All [a] (-> Nat (Stream a) a)) + (let [[h t] (cont;run s)] + (if (>+ +0 idx) + (at (dec+ idx) t) + h))) + +(do-template [<taker> <dropper> <splitter> <pred-type> <pred-test> <pred-step>] + [(def: #export (<taker> pred xs) + (All [a] + (-> <pred-type> (Stream a) (List a))) + (let [[x xs'] (cont;run xs)] + (if <pred-test> + (list& x (<taker> <pred-step> xs')) + (list)))) + + (def: #export (<dropper> pred xs) + (All [a] + (-> <pred-type> (Stream a) (Stream a))) + (let [[x xs'] (cont;run xs)] + (if <pred-test> + (<dropper> <pred-step> xs') + xs))) + + (def: #export (<splitter> pred xs) + (All [a] + (-> <pred-type> (Stream a) [(List a) (Stream a)])) + (let [[x xs'] (cont;run xs)] + (if <pred-test> + (let [[tail next] (<splitter> <pred-step> xs')] + [(#;Cons [x tail]) next]) + [(list) xs])))] + + [take-while drop-while split-with (-> a Bool) (pred x) pred] + [take drop split Nat (>+ +0 pred) (dec+ pred)] + ) + +(def: #export (unfold step init) + (All [a b] + (-> (-> a [a b]) a (Stream b))) + (let [[next x] (step init)] + (@lazy [x (unfold step next)]))) + +(def: #export (filter p xs) + (All [a] (-> (-> a Bool) (Stream a) (Stream a))) + (let [[x xs'] (cont;run xs)] + (if (p x) + (@lazy [x (filter p xs')]) + (filter p xs')))) + +(def: #export (partition p xs) + (All [a] (-> (-> a Bool) (Stream a) [(Stream a) (Stream a)])) + [(filter p xs) (filter (complement p) xs)]) + +## [Structures] +(struct: #export _ (Functor Stream) + (def: (map f fa) + (let [[h t] (cont;run fa)] + (@lazy [(f h) (map f t)])))) + +(struct: #export _ (CoMonad Stream) + (def: functor Functor<Stream>) + (def: unwrap head) + (def: (split wa) + (let [[head tail] (cont;run wa)] + (@lazy [wa (split tail)])))) + +## [Pattern-matching] +(syntax: #export (^stream& {patterns (s;form (s;many s;any))} body {branches (s;some s;any)}) + {#;doc (doc "Allows destructuring of streams in pattern-matching expressions." + "Caveat emptor: Only use it for destructuring, and not for testing values within the streams." + (let [(^stream& x y z _tail) (some-stream-func 1 2 3)] + (func x y z)))} + (with-gensyms [g!s] + (let [body+ (` (let [(~@ (List/join (List/map (lambda [pattern] + (list (` [(~ pattern) (~ g!s)]) + (` (cont;run (~ g!s))))) + patterns)))] + (~ body)))] + (wrap (list& g!s body+ branches))))) diff --git a/stdlib/source/lux/compiler.lux b/stdlib/source/lux/compiler.lux new file mode 100644 index 000000000..d7b072a56 --- /dev/null +++ b/stdlib/source/lux/compiler.lux @@ -0,0 +1,559 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: {#;doc "Functions for extracting information from the state of the compiler."} + lux + (lux (macro [ast]) + (control functor + applicative + monad) + (data (struct [list #* "List/" Monoid<List> Monad<List>]) + [number] + [text "Text/" Monoid<Text> Eq<Text>] + [product] + [ident "Ident/" Codec<Text,Ident>] + maybe + error))) + +## (type: (Lux a) +## (-> Compiler (Error [Compiler a]))) + +(struct: #export _ (Functor Lux) + (def: (map f fa) + (lambda [state] + (case (fa state) + (#;Left msg) + (#;Left msg) + + (#;Right [state' a]) + (#;Right [state' (f a)]))))) + +(struct: #export _ (Applicative Lux) + (def: functor Functor<Lux>) + + (def: (wrap x) + (lambda [state] + (#;Right [state x]))) + + (def: (apply ff fa) + (lambda [state] + (case (ff state) + (#;Right [state' f]) + (case (fa state') + (#;Right [state'' a]) + (#;Right [state'' (f a)]) + + (#;Left msg) + (#;Left msg)) + + (#;Left msg) + (#;Left msg))))) + +(struct: #export _ (Monad Lux) + (def: applicative Applicative<Lux>) + + (def: (join mma) + (lambda [state] + (case (mma state) + (#;Left msg) + (#;Left msg) + + (#;Right [state' ma]) + (ma state'))))) + +(def: (get k plist) + (All [a] + (-> Text (List [Text a]) (Maybe a))) + (case plist + #;Nil + #;None + + (#;Cons [k' v] plist') + (if (Text/= k k') + (#;Some v) + (get k plist')))) + +(def: #export (run' compiler action) + (All [a] (-> Compiler (Lux a) (Error [Compiler a]))) + (action compiler)) + +(def: #export (run compiler action) + (All [a] (-> Compiler (Lux a) (Error a))) + (case (action compiler) + (#;Left error) + (#;Left error) + + (#;Right [_ output]) + (#;Right output))) + +(def: #export (either left right) + (All [a] (-> (Lux a) (Lux a) (Lux a))) + (lambda [compiler] + (case (left compiler) + (#;Left error) + (right compiler) + + (#;Right [compiler' output]) + (#;Right [compiler' output])))) + +(def: #export (assert test message) + (-> Bool Text (Lux Unit)) + (lambda [compiler] + (if test + (#;Right [compiler []]) + (#;Left message)))) + +(def: #export (fail msg) + (All [a] + (-> Text (Lux a))) + (lambda [_] + (#;Left msg))) + +(def: #export (find-module name) + (-> Text (Lux Module)) + (lambda [state] + (case (get name (get@ #;modules state)) + (#;Some module) + (#;Right [state module]) + + _ + (#;Left ($_ Text/append "Unknown module: " name))))) + +(def: #export current-module-name + (Lux Text) + (lambda [state] + (case (list;last (get@ #;scopes state)) + (#;Some scope) + (case (get@ #;name scope) + (#;Cons m-name #;Nil) + (#;Right [state m-name]) + + _ + (#;Left "Improper name for scope.")) + + _ + (#;Left "Empty environment!") + ))) + +(def: #export current-module + (Lux Module) + (do Monad<Lux> + [this-module-name current-module-name] + (find-module this-module-name))) + +(def: #export (get-ann tag meta) + (-> Ident Anns (Maybe Ann-Value)) + (let [[p n] tag] + (case meta + (#;Cons [[p' n'] dmv] meta') + (if (and (Text/= p p') + (Text/= n n')) + (#;Some dmv) + (get-ann tag meta')) + + #;Nil + #;None))) + +(do-template [<name> <tag> <type>] + [(def: #export (<name> tag meta) + (-> Ident Anns (Maybe <type>)) + (case (get-ann tag meta) + (#;Some (<tag> value)) + (#;Some value) + + _ + #;None))] + + [get-bool-ann #;BoolM Bool] + [get-int-ann #;IntM Int] + [get-real-ann #;RealM Real] + [get-char-ann #;CharM Char] + [get-text-ann #;TextM Text] + [get-ident-ann #;IdentM Ident] + [get-list-ann #;ListM (List Ann-Value)] + [get-dict-ann #;DictM (List [Text Ann-Value])] + ) + +(def: #export (get-doc meta) + (-> Anns (Maybe Text)) + (get-text-ann ["lux" "doc"] meta)) + +(def: #export (flag-set? flag-name meta) + (-> Ident Anns Bool) + (case (get-ann flag-name meta) + (#;Some (#;BoolM true)) + true + + _ + false)) + +(do-template [<name> <tag>] + [(def: #export <name> + (-> Anns Bool) + (flag-set? (ident-for <tag>)))] + + [export? #;export?] + [hidden? #;hidden?] + [macro? #;macro?] + [type? #;type?] + [struct? #;struct?] + [type-rec? #;type-rec?] + [sig? #;sig?] + ) + +(do-template [<name> <tag> <type>] + [(def: (<name> dmv) + (-> Ann-Value (Maybe <type>)) + (case dmv + (<tag> actual-value) + (#;Some actual-value) + + _ + #;None))] + + [try-mlist #;ListM (List Ann-Value)] + [try-mtext #;TextM Text] + ) + +(do-template [<name> <tag>] + [(def: #export (<name> meta) + (-> Anns (List Text)) + (default (list) + (do Monad<Maybe> + [_args (get-ann (ident-for <tag>) meta) + args (try-mlist _args)] + (mapM @ try-mtext args))))] + + [func-args #;func-args] + [type-args #;type-args] + ) + +(def: (find-macro' modules this-module module name) + (-> (List [Text Module]) Text Text Text + (Maybe Macro)) + (do Monad<Maybe> + [$module (get module modules) + [def-type def-anns def-value] (: (Maybe Def) (|> (: Module $module) (get@ #;defs) (get name)))] + (if (and (macro? def-anns) + (or (export? def-anns) (Text/= module this-module))) + (#;Some (:! Macro def-value)) + (case (get-ann ["lux" "alias"] def-anns) + (#;Some (#;IdentM [r-module r-name])) + (find-macro' modules this-module r-module r-name) + + _ + #;None)))) + +(def: #export (find-macro ident) + (-> Ident (Lux (Maybe Macro))) + (do Monad<Lux> + [this-module current-module-name] + (let [[module name] ident] + (: (Lux (Maybe Macro)) + (lambda [state] + (#;Right [state (find-macro' (get@ #;modules state) this-module module name)])))))) + +(def: #export (normalize ident) + (-> Ident (Lux Ident)) + (case ident + ["" name] + (do Monad<Lux> + [module-name current-module-name] + (wrap [module-name name])) + + _ + (:: Monad<Lux> wrap ident))) + +(def: #export (macro-expand-once syntax) + (-> AST (Lux (List AST))) + (case syntax + [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] + (do Monad<Lux> + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (case ?macro + (#;Some macro) + (macro args) + + #;None + (:: Monad<Lux> wrap (list syntax)))) + + _ + (:: Monad<Lux> wrap (list syntax)))) + +(def: #export (macro-expand syntax) + (-> AST (Lux (List AST))) + (case syntax + [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] + (do Monad<Lux> + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (case ?macro + (#;Some macro) + (do Monad<Lux> + [expansion (macro args) + expansion' (mapM Monad<Lux> macro-expand expansion)] + (wrap (:: Monad<List> join expansion'))) + + #;None + (:: Monad<Lux> wrap (list syntax)))) + + _ + (:: Monad<Lux> wrap (list syntax)))) + +(def: #export (macro-expand-all syntax) + (-> AST (Lux (List AST))) + (case syntax + [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] + (do Monad<Lux> + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (case ?macro + (#;Some macro) + (do Monad<Lux> + [expansion (macro args) + expansion' (mapM Monad<Lux> macro-expand-all expansion)] + (wrap (:: Monad<List> join expansion'))) + + #;None + (do Monad<Lux> + [parts' (mapM Monad<Lux> macro-expand-all (list& (ast;symbol macro-name) args))] + (wrap (list (ast;form (:: Monad<List> join parts'))))))) + + [_ (#;FormS (#;Cons [harg targs]))] + (do Monad<Lux> + [harg+ (macro-expand-all harg) + targs+ (mapM Monad<Lux> macro-expand-all targs)] + (wrap (list (ast;form (List/append harg+ (:: Monad<List> join (: (List (List AST)) targs+))))))) + + [_ (#;TupleS members)] + (do Monad<Lux> + [members' (mapM Monad<Lux> macro-expand-all members)] + (wrap (list (ast;tuple (:: Monad<List> join members'))))) + + _ + (:: Monad<Lux> wrap (list syntax)))) + +(def: #export (gensym prefix) + (-> Text (Lux AST)) + (lambda [state] + (#;Right [(update@ #;seed inc+ state) + (ast;symbol ["" ($_ Text/append "__gensym__" prefix (:: number;Codec<Text,Nat> encode (get@ #;seed state)))])]))) + +(def: (get-local-symbol ast) + (-> AST (Lux Text)) + (case ast + [_ (#;SymbolS [_ name])] + (:: Monad<Lux> wrap name) + + _ + (fail (Text/append "AST is not a local symbol: " (ast;ast-to-text ast))))) + +(macro: #export (with-gensyms tokens) + {#;doc (doc "Creates new symbols and offers them to the body expression." + (syntax: #export (synchronized lock body) + (with-gensyms [g!lock g!body g!_] + (wrap (list (` (let [(~ g!lock) (~ lock) + (~ g!_) (;_jvm_monitorenter (~ g!lock)) + (~ g!body) (~ body) + (~ g!_) (;_jvm_monitorexit (~ g!lock))] + (~ g!body))))) + )))} + (case tokens + (^ (list [_ (#;TupleS symbols)] body)) + (do Monad<Lux> + [symbol-names (mapM @ get-local-symbol symbols) + #let [symbol-defs (List/join (List/map (: (-> Text (List AST)) + (lambda [name] (list (ast;symbol ["" name]) (` (gensym (~ (ast;text name))))))) + symbol-names))]] + (wrap (list (` (do Monad<Lux> + [(~@ symbol-defs)] + (~ body)))))) + + _ + (fail "Wrong syntax for with-gensyms"))) + +(def: #export (macro-expand-1 token) + (-> AST (Lux AST)) + (do Monad<Lux> + [token+ (macro-expand token)] + (case token+ + (^ (list token')) + (wrap token') + + _ + (fail "Macro expanded to more than 1 element.")))) + +(def: #export (module-exists? module) + (-> Text (Lux Bool)) + (lambda [state] + (#;Right [state (case (get module (get@ #;modules state)) + (#;Some _) + true + + #;None + false)]))) + +(def: (try-both f x1 x2) + (All [a b] + (-> (-> a (Maybe b)) a a (Maybe b))) + (case (f x1) + #;None (f x2) + (#;Some y) (#;Some y))) + +(def: #export (find-var-type name) + (-> Text (Lux Type)) + (lambda [state] + (let [test (: (-> [Text Analysis] Bool) + (|>. product;left (Text/= name)))] + (case (do Monad<Maybe> + [scope (find (lambda [env] + (or (any? test (get@ [#;locals #;mappings] env)) + (any? test (get@ [#;closure #;mappings] env)))) + (get@ #;scopes state)) + [_ [[type _] _]] (try-both (find test) + (get@ [#;locals #;mappings] scope) + (get@ [#;closure #;mappings] scope))] + (wrap type)) + (#;Some var-type) + (#;Right [state var-type]) + + #;None + (#;Left ($_ Text/append "Unknown variable: " name)))))) + +(def: #export (find-def name) + (-> Ident (Lux Def)) + (lambda [state] + (case (: (Maybe Def) + (do Monad<Maybe> + [#let [[v-prefix v-name] name] + (^slots [#;defs]) (get v-prefix (get@ #;modules state))] + (get v-name defs))) + (#;Some _meta) + (#;Right [state _meta]) + + _ + (#;Left ($_ Text/append "Unknown definition: " (Ident/encode name)))))) + +(def: #export (find-def-type name) + (-> Ident (Lux Type)) + (do Monad<Lux> + [[def-type def-data def-value] (find-def name)] + (wrap def-type))) + +(def: #export (find-type name) + (-> Ident (Lux Type)) + (do Monad<Lux> + [#let [[_ _name] name]] + (either (find-var-type _name) + (do @ + [name (normalize name)] + (find-def-type name))))) + +(def: #export (find-type-def name) + (-> Ident (Lux Type)) + (do Monad<Lux> + [[def-type def-data def-value] (find-def name)] + (wrap (:! Type def-value)))) + +(def: #export (defs module-name) + (-> Text (Lux (List [Text Def]))) + (lambda [state] + (case (get module-name (get@ #;modules state)) + #;None (#;Left ($_ Text/append "Unknown module: " module-name)) + (#;Some module) (#;Right [state (get@ #;defs module)]) + ))) + +(def: #export (exports module-name) + (-> Text (Lux (List [Text Def]))) + (do Monad<Lux> + [defs (defs module-name)] + (wrap (filter (lambda [[name [def-type def-anns def-value]]] + (and (export? def-anns) + (not (hidden? def-anns)))) + defs)))) + +(def: #export modules + (Lux (List Text)) + (lambda [state] + (|> state + (get@ #;modules) + (List/map product;left) + [state] + #;Right))) + +(def: #export (tags-of type-name) + (-> Ident (Lux (List Ident))) + (do Monad<Lux> + [#let [[module name] type-name] + module (find-module module)] + (case (get name (get@ #;types module)) + (#;Some [tags _]) + (wrap tags) + + _ + (wrap (list))))) + +(def: #export cursor + (Lux Cursor) + (lambda [state] + (#;Right [state (get@ #;cursor state)]))) + +(def: #export expected-type + (Lux Type) + (lambda [state] + (case (get@ #;expected state) + (#;Some type) + (#;Right [state type]) + + #;None + (#;Left "Not expecting any type.")))) + +(def: #export (imported-modules module-name) + (-> Text (Lux (List Text))) + (do Monad<Lux> + [(^slots [#;imports]) (find-module module-name)] + (wrap imports))) + +(def: #export (resolve-tag (^@ tag [module name])) + (-> Ident (Lux [Nat (List Ident) Type])) + (do Monad<Lux> + [=module (find-module module) + this-module-name current-module-name] + (case (get name (get@ #;tags =module)) + (#;Some [idx tag-list exported? type]) + (if (or exported? + (Text/= this-module-name module)) + (wrap [idx tag-list type]) + (fail ($_ Text/append "Can't access tag: " (Ident/encode tag) " from module " this-module-name))) + + _ + (fail ($_ Text/append "Unknown tag: " (Ident/encode tag)))))) + +(def: #export locals + (Lux (List (List [Text Type]))) + (lambda [state] + (case (list;inits (get@ #;scopes state)) + #;None + (#;Left "No local environment") + + (#;Some scopes) + (#;Right [state + (List/map (|>. (get@ [#;locals #;mappings]) + (List/map (lambda [[name [[type cursor] analysis]]] + [name type]))) + scopes)])))) + +(def: #export (un-alias def-name) + (-> Ident (Lux Ident)) + (do Monad<Lux> + [def-name (normalize def-name) + [_ def-anns _] (find-def def-name)] + (case (get-ann (ident-for #;alias) def-anns) + (#;Some (#;IdentM real-def-name)) + (wrap real-def-name) + + _ + (wrap def-name)))) diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux new file mode 100644 index 000000000..1eb3cee21 --- /dev/null +++ b/stdlib/source/lux/concurrency/actor.lux @@ -0,0 +1,278 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monad) + (codata [io #- run] + function) + (data error + text/format + (struct [list "List/" Monoid<List> Monad<List>]) + [product] + [number "Nat/" Codec<Text,Nat>]) + [compiler #+ with-gensyms] + (macro [ast] + ["s" syntax #+ syntax: Syntax] + (syntax [common])) + [type]) + (.. [promise #+ Monad<Promise>] + [stm #+ Monad<STM>] + [frp])) + +## [Types] +(type: #export (Actor s m) + {#mailbox (stm;Var m) + #kill-signal (promise;Promise Unit) + #obituary (promise;Promise [(Maybe Text) s (List m)])}) + +(type: #export (Proc s m) + {#step (-> (Actor s m) (-> m s (promise;Promise (Error s)))) + #end (-> (Maybe Text) s (promise;Promise Unit))}) + +## [Values] +(def: #export (spawn init [proc on-death]) + {#;doc "Given a procedure and initial state, launches an actor and returns it."} + (All [s m] (-> s (Proc s m) (IO (Actor s m)))) + (io (let [mailbox (stm;var (:! ($ 1) [])) + kill-signal (promise;promise Unit) + obituary (promise;promise [(Maybe Text) ($ 0) (List ($ 1))]) + self {#mailbox mailbox + #kill-signal kill-signal + #obituary obituary} + mailbox-chan (io;run (stm;follow "\tmailbox\t" mailbox)) + proc (proc self) + |mailbox| (stm;var mailbox-chan) + _ (:: Monad<Promise> map + (lambda [_] + (io;run (do Monad<IO> + [mb (stm;read! |mailbox|)] + (frp;close mb)))) + kill-signal) + process (loop [state init + messages mailbox-chan] + (do Monad<Promise> + [?messages+ messages] + (case ?messages+ + ## No kill-signal so far, so I may proceed... + (#;Some [message messages']) + (do Monad<Promise> + [#let [_ (io;run (stm;write! messages' |mailbox|))] + ?state' (proc message state)] + (case ?state' + (#;Left error) + (do @ + [#let [_ (io;run (promise;resolve [] kill-signal)) + _ (io;run (frp;close messages')) + death-message (#;Some error)] + _ (on-death death-message state) + remaining-messages (frp;consume messages')] + (wrap [death-message state (#;Cons message remaining-messages)])) + + (#;Right state') + (recur state' messages'))) + + ## Otherwise, clean-up and return current state. + #;None + (do Monad<Promise> + [#let [_ (io;run (frp;close messages)) + death-message #;None] + _ (on-death death-message state)] + (wrap [death-message state (list)])))))] + self))) + +(def: #export poison + {#;doc "Immediately kills the given actor (if it's not already dead)."} + (All [s m] (-> (Actor s m) (io;IO Bool))) + (|>. (get@ #kill-signal) (promise;resolve []))) + +(def: #export (alive? actor) + (All [s m] (-> (Actor s m) Bool)) + (case [(promise;poll (get@ #kill-signal actor)) + (promise;poll (get@ #obituary actor))] + [#;None #;None] + true + + _ + false)) + +(def: #export (send message actor) + (All [s m] (-> m (Actor s m) (promise;Promise Bool))) + (if (alive? actor) + (exec (io;run (stm;write! message (get@ #mailbox actor))) + (:: Monad<Promise> wrap true)) + (:: Monad<Promise> wrap false))) + +(def: #export (keep-alive init proc) + {#;doc "Given initial-state and a procedure, launches and actor that will reboot if it dies of errors. + However, it can still be killed."} + (All [s m] (-> s (Proc s m) (IO (Actor s m)))) + (io (let [ka-actor (: (Actor (Actor ($ 0) ($ 1)) ($ 1)) + (io;run (spawn (io;run (spawn init proc)) + {#step (lambda [*self* message server] + (do Monad<Promise> + [was-sent? (send message server)] + (if was-sent? + (wrap (#;Right server)) + (do @ + [[?cause state unprocessed-messages] (get@ #obituary server)] + (exec (log! (format "ACTOR DIED:\n" (default "" ?cause) "\n RESTARTING")) + (do @ + [#let [new-server (io;run (spawn state proc)) + mailbox (get@ #mailbox new-server)] + _ (promise;future (mapM io;Monad<IO> ((flip stm;write!) mailbox) (#;Cons message unprocessed-messages)))] + (wrap (#;Right new-server)))) + )))) + #end (lambda [_ server] (exec (io;run (poison server)) + (:: Monad<Promise> wrap [])))})))] + (update@ #obituary (: (-> (promise;Promise [(Maybe Text) (Actor ($ 0) ($ 1)) (List ($ 1))]) + (promise;Promise [(Maybe Text) ($ 0) (List ($ 1))])) + (lambda [process] + (do Monad<Promise> + [[_ server unprocessed-messages-0] process + [cause state unprocessed-messages-1] (get@ #obituary server)] + (wrap [cause state (List/append unprocessed-messages-0 unprocessed-messages-1)])))) + ka-actor)))) + +## [Syntax] +(type: Method + {#name Text + #vars (List Text) + #args (List [Text AST]) + #return AST + #body AST}) + +(def: method^ + (Syntax Method) + (s;form (do s;Monad<Syntax> + [_ (s;symbol! ["" "method:"]) + vars (s;default (list) (s;tuple (s;some s;local-symbol))) + [name args] (s;form ($_ s;seq + s;local-symbol + (s;many common;typed-arg) + )) + return s;any + body s;any] + (wrap {#name name + #vars vars + #args args + #return return + #body body})))) + +(def: stop^ + (Syntax AST) + (s;form (do s;Monad<Syntax> + [_ (s;symbol! ["" "stop:"])] + s;any))) + +(def: actor-decl^ + (Syntax [(List Text) Text (List [Text AST])]) + (s;seq (s;default (list) (s;tuple (s;some s;local-symbol))) + (s;either (s;form (s;seq s;local-symbol (s;many common;typed-arg))) + (s;seq s;local-symbol (:: s;Monad<Syntax> wrap (list)))))) + +(def: (actor-def-decl [_vars _name _args] return-type) + (-> [(List Text) Text (List [Text AST])] AST (List AST)) + (let [decl (` ((~ (ast;symbol ["" (format _name "//new")])) (~@ (List/map (|>. product;left [""] ast;symbol) _args)))) + base-type (` (-> (~@ (List/map product;right _args)) + (~ return-type))) + type (case _vars + #;Nil + base-type + + _ + (` (All [(~@ (List/map (|>. [""] ast;symbol) _vars))] + (~ base-type))))] + (list decl + type))) + +(syntax: #export (actor: {_ex-lev common;export-level} + {(^@ decl [_vars _name _args]) actor-decl^} + state-type + {methods (s;many method^)} + {?stop (s;opt stop^)}) + {#;doc (doc "Allows defining an actor, with a set of methods that can be called on it." + "The methods can return promisehronous outputs." + "The methods can access the actor's state through the *state* variable." + "The methods can also access the actor itself through the *self* variable." + + (actor: #export Adder + Int + + (method: (count! {to-add Int}) + [Int Int] + (if (>= 0 to-add) + (do Monad<Promise> + [#let [new-state (+ to-add *state*)]] + (wrap (#;Right [new-state [*state* new-state]]))) + (do Monad<Promise> + [] + (wrap (#;Left "Can't add negative numbers!"))))) + ))} + (with-gensyms [g!message g!error g!return g!error g!output] + (let [g!state-name (ast;symbol ["" (format _name "//STATE")]) + g!protocol-name (ast;symbol ["" (format _name "//PROTOCOL")]) + g!self (ast;symbol ["" "*self*"]) + g!state (ast;symbol ["" "*state*"]) + g!cause (ast;symbol ["" "*cause*"]) + g!stop-body (default (` (:: promise;Monad<Promise> (~' wrap) [])) ?stop) + protocol (List/map (lambda [(^slots [#name #vars #args #return #body])] + (` ((~ (ast;tag ["" name])) [(~@ (List/map product;right args))] (promise;Promise (~ return))))) + methods) + protocol-pm (List/map (: (-> Method [AST AST]) + (lambda [(^slots [#name #vars #args #return #body])] + (let [arg-names (|> (list;size args) (list;range+ +1) (List/map (|>. Nat/encode [""] ast;symbol))) + body-func (` (: (-> (~ g!state-name) (~@ (List/map product;right args)) (promise;Promise (Error [(~ g!state-name) (~ return)]))) + (lambda (~ (ast;symbol ["" _name])) [(~ g!state) (~@ (List/map (|>. product;left [""] ast;symbol) args))] + (do promise;Monad<Promise> + [] + (~ body)))))] + [(` [[(~@ arg-names)] (~ g!return)]) + (` (do promise;Monad<Promise> + [(~ g!output) ((~ body-func) (~ g!state) (~@ arg-names))] + (case (~ g!output) + (#;Right [(~ g!state) (~ g!output)]) + (exec (io;run (promise;resolve (~ g!output) (~ g!return))) + ((~' wrap) (#;Right (~ g!state)))) + + (#;Left (~ g!error)) + ((~' wrap) (#;Left (~ g!error)))) + ))]))) + methods) + g!proc (` {#step (lambda [(~ g!self) (~ g!message) (~ g!state)] + (case (~ g!message) + (~@ (if (=+ +1 (list;size protocol-pm)) + (List/join (List/map (lambda [[pattern clause]] + (list pattern clause)) + protocol-pm)) + (List/join (List/map (lambda [[method [pattern clause]]] + (list (` ((~ (ast;tag ["" (get@ #name method)])) (~ pattern))) + clause)) + (list;zip2 methods protocol-pm))))) + )) + #end (lambda [(~ g!cause) (~ g!state)] + (do promise;Monad<Promise> + [] + (~ g!stop-body)))}) + g!actor-name (ast;symbol ["" _name]) + g!methods (List/map (: (-> Method AST) + (lambda [(^slots [#name #vars #args #return #body])] + (let [arg-names (|> (list;size args) (list;range+ +1) (List/map (|>. Nat/encode [""] ast;symbol))) + type (` (-> (~@ (List/map product;right args)) + (~ g!actor-name) + (promise;Promise (~ return))))] + (` (def: (~@ (common;gen-export-level _ex-lev)) ((~ (ast;symbol ["" name])) (~@ arg-names) (~ g!self)) + (~ type) + (let [(~ g!output) (promise;promise (~ return))] + (exec (send ((~ (ast;tag ["" name])) [[(~@ arg-names)] (~ g!output)]) (~ g!self)) + (~ g!output)))))))) + methods)] + (wrap (list& (` (type: (~@ (common;gen-export-level _ex-lev)) (~ g!state-name) (~ state-type))) + (` (type: (~@ (common;gen-export-level _ex-lev)) (~ g!protocol-name) (~@ protocol))) + (` (type: (~@ (common;gen-export-level _ex-lev)) (~ g!actor-name) (Actor (~ g!state-name) (~ g!protocol-name)))) + (` (def: (~@ (common;gen-export-level _ex-lev)) (~@ (actor-def-decl decl (` (Proc (~ g!state-name) (~ g!protocol-name))))) + (~ g!proc))) + g!methods)) + ))) diff --git a/stdlib/source/lux/concurrency/atom.lux b/stdlib/source/lux/concurrency/atom.lux new file mode 100644 index 000000000..3905ee7ca --- /dev/null +++ b/stdlib/source/lux/concurrency/atom.lux @@ -0,0 +1,41 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io #- run]) + host) + ) + +(jvm-import (java.util.concurrent.atomic.AtomicReference V) + (new [V]) + (compareAndSet [V V] boolean) + (get [] V)) + +(type: #export (Atom a) + (AtomicReference a)) + +(def: #export (atom value) + (All [a] (-> a (Atom a))) + (AtomicReference.new [value])) + +(def: #export (get atom) + (All [a] (-> (Atom a) (IO a))) + (io (AtomicReference.get [] atom))) + +(def: #export (compare-and-swap old new atom) + (All [a] (-> a a (Atom a) (IO Bool))) + (io (AtomicReference.compareAndSet [old new] atom))) + +(def: #export (update f atom) + (All [a] (-> (-> a a) (Atom a) (IO Unit))) + (io (let [old (AtomicReference.get [] atom)] + (if (AtomicReference.compareAndSet [old (f old)] atom) + [] + (io;run (update f atom)))))) + +(def: #export (set value atom) + (All [a] (-> a (Atom a) (IO Unit))) + (update (lambda [_] value) atom)) diff --git a/stdlib/source/lux/concurrency/frp.lux b/stdlib/source/lux/concurrency/frp.lux new file mode 100644 index 000000000..0efa9f837 --- /dev/null +++ b/stdlib/source/lux/concurrency/frp.lux @@ -0,0 +1,194 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + applicative + monad + eq) + (codata [io #- run] + function) + (data (struct [list]) + text/format) + [compiler] + (macro ["s" syntax #+ syntax: Syntax])) + (.. ["&" promise])) + +## [Types] +(type: #export (Chan a) + (&;Promise (Maybe [a (Chan a)]))) + +## [Syntax] +(syntax: #export (chan {?type (s;opt s;any)}) + {#;doc (doc "Makes an uninitialized Chan (in this case, of Unit)." + (chan Unit))} + (case ?type + (#;Some type) + (wrap (list (` (: (Chan (~ type)) + (&;promise))))) + + #;None + (wrap (list (` (&;promise)))))) + +## [Values] +(def: #export (filter p xs) + (All [a] (-> (-> a Bool) (Chan a) (Chan a))) + (do &;Monad<Promise> + [?x+xs xs] + (case ?x+xs + #;None (wrap #;None) + (#;Some [x xs']) (if (p x) + (wrap (#;Some [x (filter p xs')])) + (filter p xs'))))) + +(def: #export (write value chan) + (All [a] (-> a (Chan a) (IO (Maybe (Chan a))))) + (case (&;poll chan) + (^template [<case> <chan-to-write>] + <case> + (do Monad<IO> + [#let [new-tail (&;promise)] + done? (&;resolve (#;Some [value new-tail]) <chan-to-write>)] + (if done? + (wrap (#;Some new-tail)) + (write value <chan-to-write>)))) + ([#;None chan] + [(#;Some (#;Some [_ chan'])) chan']) + + _ + (:: Monad<IO> wrap #;None) + )) + +(def: #export (close chan) + (All [a] (-> (Chan a) (IO Bool))) + (case (&;poll chan) + (^template [<case> <chan-to-write>] + <case> + (do Monad<IO> + [done? (&;resolve #;None <chan-to-write>)] + (if done? + (wrap true) + (close <chan-to-write>)))) + ([#;None chan] + [(#;Some (#;Some [_ chan'])) chan']) + + _ + (:: Monad<IO> wrap false) + )) + +(def: (pipe' input output) + (All [a] (-> (Chan a) (Chan a) (&;Promise Unit))) + (do &;Monad<Promise> + [?x+xs input] + (case ?x+xs + #;None (wrap []) + (#;Some [x input']) (case (io;run (write x output)) + #;None + (wrap []) + + (#;Some output') + (pipe' input' output'))))) + +(def: #export (pipe input output) + (All [a] (-> (Chan a) (Chan a) (&;Promise Unit))) + (do &;Monad<Promise> + [_ (pipe' input output)] + (exec (io;run (close output)) + (wrap [])))) + +(def: #export (merge xss) + (All [a] (-> (List (Chan a)) (Chan a))) + (let [output (chan ($ 0))] + (exec (do &;Monad<Promise> + [_ (mapM @ (lambda [input] (pipe' input output)) xss)] + (exec (io;run (close output)) + (wrap []))) + output))) + +(def: #export (fold f init xs) + (All [a b] (-> (-> b a (&;Promise a)) a (Chan b) (&;Promise a))) + (do &;Monad<Promise> + [?x+xs xs] + (case ?x+xs + #;None (wrap init) + (#;Some [x xs']) (do @ + [init' (f x init)] + (fold f init' xs'))))) + +(def: (no-dups' eq last-one xs) + (All [a] (-> (Eq a) a (Chan a) (Chan a))) + (let [(^open) eq] + (do &;Monad<Promise> + [?x+xs xs] + (case ?x+xs + #;None (wrap #;None) + (#;Some [x xs']) (if (= x last-one) + (no-dups' eq last-one xs') + (wrap (#;Some [x (no-dups' eq x xs')]))))))) + +(def: #export (no-dups eq xs) + {#;doc "Multiple consecutive equal values in the input channel will just be single values in the output channel."} + (All [a] (-> (Eq a) (Chan a) (Chan a))) + (let [(^open) eq] + (do &;Monad<Promise> + [?x+xs xs] + (case ?x+xs + #;None (wrap #;None) + (#;Some [x xs']) (wrap (#;Some [x (no-dups' eq x xs')])))))) + +(def: #export (consume xs) + (All [a] (-> (Chan a) (&;Promise (List a)))) + (do &;Monad<Promise> + [?x+xs' xs] + (case ?x+xs' + #;None + (wrap #;Nil) + + (#;Some [x xs']) + (do @ + [=xs (consume xs')] + (wrap (#;Cons x =xs)))))) + +(def: #export (as-chan !x) + (All [a] (-> (&;Promise a) (Chan a))) + (do &;Monad<Promise> + [x !x] + (wrap (#;Some [x (wrap #;None)])))) + +## [Structures] +(struct: #export _ (Functor Chan) + (def: (map f xs) + (:: &;Functor<Promise> map + (lambda [?x+xs] + (case ?x+xs + #;None #;None + (#;Some [x xs']) (#;Some [(f x) (map f xs')]))) + xs))) + +(struct: #export _ (Applicative Chan) + (def: functor Functor<Chan>) + + (def: (wrap a) + (let [(^open) &;Monad<Promise>] + (wrap (#;Some [a (wrap #;None)])))) + + (def: (apply ff fa) + (let [fb (chan ($ 1))] + (exec (let [(^open) Functor<Chan>] + (map (lambda [f] (pipe (map f fa) fb)) + ff)) + fb)))) + +(struct: #export _ (Monad Chan) + (def: applicative Applicative<Chan>) + + (def: (join mma) + (let [output (chan ($ 0))] + (exec (let [(^open) Functor<Chan>] + (map (lambda [ma] + (pipe ma output)) + mma)) + output)))) diff --git a/stdlib/source/lux/concurrency/promise.lux b/stdlib/source/lux/concurrency/promise.lux new file mode 100644 index 000000000..b765acc4d --- /dev/null +++ b/stdlib/source/lux/concurrency/promise.lux @@ -0,0 +1,233 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (data (struct [list #* "" Functor<List>]) + number + text/format + error) + (codata [io #- run] + function) + (control functor + applicative + monad) + [compiler] + (macro ["s" syntax #+ syntax: Syntax]) + (concurrency [atom #+ Atom atom]) + host + )) + +(jvm-import java.lang.Runtime + (#static getRuntime [] Runtime) + (availableProcessors [] int)) + +(jvm-import java.lang.Runnable) + +(jvm-import java.lang.Thread + (new [Runnable]) + (start [] void)) + +(jvm-import java.util.concurrent.Executor + (execute [Runnable] void)) + +(jvm-import java.util.concurrent.TimeUnit + (#enum MILLISECONDS)) + +(jvm-import (java.util.concurrent.ScheduledFuture a)) + +(jvm-import java.util.concurrent.ScheduledThreadPoolExecutor + (new [int]) + (schedule [Runnable long TimeUnit] (ScheduledFuture Object))) + +(def: #export concurrency-level + Nat + (|> (Runtime.getRuntime []) + (Runtime.availableProcessors []) + int-to-nat)) + +(def: executor + ScheduledThreadPoolExecutor + (ScheduledThreadPoolExecutor.new [(nat-to-int concurrency-level)])) + +(syntax: (runnable expr) + (wrap (list (`' (object [java.lang.Runnable] + [] + (java.lang.Runnable (run) void + (exec (~ expr) + []))))))) + +(type: (Promise-State a) + {#value (Maybe a) + #observers (List (-> a (IO Unit)))}) + +(type: #export (Promise a) + {#;doc "Represents values produced by promisehronous computations (unlike IO, which is synchronous)."} + (Atom (Promise-State a))) + +(def: #hidden (promise' ?value) + (All [a] (-> (Maybe a) (Promise a))) + (atom {#value ?value + #observers (list)})) + +(syntax: #export (promise {?type (s;opt s;any)}) + {#;doc (doc "Makes an uninitialized Promise (in this example, of Unit)." + (promise Unit))} + (case ?type + (#;Some type) + (wrap (list (` (: (Promise (~ type)) + (promise' #;None))))) + + #;None + (wrap (list (` (promise' #;None)))))) + +(def: #export (poll promise) + {#;doc "Checks whether an Promise's value has already been resolved."} + (All [a] (-> (Promise a) (Maybe a))) + (|> (atom;get promise) + io;run + (get@ #value))) + +(def: #export (resolve value promise) + {#;doc "Sets an Promise's value if it hasn't been done yet."} + (All [a] (-> a (Promise a) (IO Bool))) + (do Monad<IO> + [old (atom;get promise)] + (case (get@ #value old) + (#;Some _) + (wrap false) + + #;None + (do @ + [#let [new (set@ #value (#;Some value) old)] + succeeded? (atom;compare-and-swap old new promise)] + (if succeeded? + (do @ + [_ (mapM @ (lambda [f] (f value)) + (get@ #observers old))] + (wrap true)) + (resolve value promise)))))) + +(def: (await f promise) + (All [a] (-> (-> a (IO Unit)) (Promise a) Unit)) + (let [old (io;run (atom;get promise))] + (case (get@ #value old) + (#;Some value) + (io;run (f value)) + + #;None + (let [new (update@ #observers (|>. (#;Cons f)) old)] + (if (io;run (atom;compare-and-swap old new promise)) + [] + (await f promise)))))) + +(struct: #export _ (Functor Promise) + (def: (map f fa) + (let [fb (promise ($ 1))] + (exec (await (lambda [a] (do Monad<IO> + [_ (resolve (f a) fb)] + (wrap []))) + fa) + fb)))) + +(struct: #export _ (Applicative Promise) + (def: functor Functor<Promise>) + + (def: (wrap a) + (atom {#value (#;Some a) + #observers (list)})) + + (def: (apply ff fa) + (let [fb (promise ($ 1))] + (exec (await (lambda [f] + (io (await (lambda [a] (do Monad<IO> + [_ (resolve (f a) fb)] + (wrap []))) + fa))) + ff) + fb)) + )) + +(struct: #export _ (Monad Promise) + (def: applicative Applicative<Promise>) + + (def: (join mma) + (let [ma (promise ($ 0))] + (exec (await (lambda [ma'] + (io (await (lambda [a'] + (do Monad<IO> + [_ (resolve a' ma)] + (wrap []))) + ma'))) + mma) + ma)))) + +(def: #export (seq left right) + {#;doc "Sequencing combinator."} + (All [a b] (-> (Promise a) (Promise b) (Promise [a b]))) + (do Monad<Promise> + [a left + b right] + (wrap [a b]))) + +(def: #export (alt left right) + {#;doc "Heterogeneous alternative combinator."} + (All [a b] (-> (Promise a) (Promise b) (Promise (| a b)))) + (let [a|b (promise (Either ($ 0) ($ 1)))] + (let% [<sides> (do-template [<promise> <tag>] + [(await (lambda [value] + (do Monad<IO> + [_ (resolve (<tag> value) a|b)] + (wrap []))) + <promise>)] + + [left #;Left] + [right #;Right] + )] + (exec <sides> + a|b)))) + +(def: #export (either left right) + {#;doc "Homogeneous alternative combinator."} + (All [a] (-> (Promise a) (Promise a) (Promise a))) + (let [left||right (promise ($ 0))] + (let% [<sides> (do-template [<promise>] + [(await [(lambda [value] + (do Monad<IO> + [_ (resolve value left||right)] + (wrap [])))] + <promise>)] + + [left] + [right] + )] + (exec <sides> + left||right)))) + +(def: #export (future computation) + {#;doc "Runs computation on it's own process and returns an Promise that will eventually host it's result."} + (All [a] (-> (IO a) (Promise a))) + (let [!out (promise ($ 0))] + (exec (Thread.start [] (Thread.new [(runnable (io;run (resolve (io;run computation) + !out)))])) + !out))) + +(def: #export (wait time) + (-> Nat (Promise Unit)) + (let [!out (promise Unit)] + (exec (ScheduledThreadPoolExecutor.schedule [(runnable (io;run (resolve [] !out))) + (nat-to-int time) + TimeUnit.MILLISECONDS] + executor) + !out))) + +(def: #export (time-out time promise) + (All [a] (-> Nat (Promise a) (Promise (Maybe a)))) + (alt (wait time) promise)) + +(def: #export (delay time value) + {#;doc "Delivers a value after a certain period has passed."} + (All [a] (-> Nat a (Promise a))) + (:: Functor<Promise> map (const value) (wait time))) diff --git a/stdlib/source/lux/concurrency/stm.lux b/stdlib/source/lux/concurrency/stm.lux new file mode 100644 index 000000000..80633a41e --- /dev/null +++ b/stdlib/source/lux/concurrency/stm.lux @@ -0,0 +1,237 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + applicative + monad) + (codata [io #- run]) + (data (struct [list #* "List/" Functor<List>] + [dict #+ Dict]) + [product] + [text] + text/format) + host + [compiler] + (macro [ast] + ["s" syntax #+ syntax: Syntax]) + (concurrency [atom #+ Atom atom] + [promise #+ Promise "Promise/" Monad<Promise>] + [frp]) + )) + +(type: (Var-State a) + {#value a + #observers (Dict Text (-> a (IO Unit)))}) + +(type: #export (Var a) + (Atom (Var-State a))) + +(type: (Tx-Frame a) + {#var (Var a) + #original a + #current a}) + +(type: Tx + (List (Ex [a] (Tx-Frame a)))) + +(type: #export (STM a) + (-> Tx [Tx a])) + +(def: #export (var value) + (All [a] (-> a (Var a))) + (atom;atom {#value value + #observers (dict;new text;Hash<Text>)})) + +(def: raw-read + (All [a] (-> (Var a) a)) + (|>. atom;get io;run (get@ #value))) + +(def: (find-var-value var tx) + (All [a] (-> (Var a) Tx (Maybe a))) + (:! (Maybe ($ 0)) + (find (: (-> (Ex [a] (Tx-Frame a)) + (Maybe Unit)) + (lambda [[_var _original _current]] + (:! (Maybe Unit) + (if (== (:! (Var Unit) var) + (:! (Var Unit) _var)) + (#;Some _current) + #;None)))) + tx))) + +(def: #export (read var) + (All [a] (-> (Var a) (STM a))) + (lambda [tx] + (case (find-var-value var tx) + (#;Some value) + [tx value] + + #;None + (let [value (raw-read var)] + [(#;Cons [var value value] tx) + value])))) + +(def: #export (read! var) + {#;doc "Reads var immediately, without going through a transaction."} + (All [a] (-> (Var a) (IO a))) + (|> var + atom;get + (:: Functor<IO> map (get@ #value)))) + +(def: (update-tx-value var value tx) + (All [a] (-> (Var a) a Tx Tx)) + (case tx + #;Nil + #;Nil + + (#;Cons [_var _original _current] tx') + (if (== (:! (Var ($ 0)) var) + (:! (Var ($ 0)) _var)) + (#;Cons [(:! (Var ($ 0)) _var) + (:! ($ 0) _original) + (:! ($ 0) _current)] + tx') + (#;Cons [_var _original _current] + (update-tx-value var value tx'))) + )) + +(def: #export (write value var) + (All [a] (-> a (Var a) (STM Unit))) + (lambda [tx] + (case (find-var-value var tx) + (#;Some _) + [(update-tx-value var value tx) + []] + + #;None + [(#;Cons [var (raw-read var) value] tx) + []]))) + +(def: #export (write! new-value var) + {#;doc "Writes value to var immediately, without going through a transaction."} + (All [a] (-> a (Var a) (IO Unit))) + (do Monad<IO> + [old (atom;get var) + #let [old-value (get@ #value old) + new (set@ #value new-value old)] + succeeded? (atom;compare-and-swap old new var)] + (if succeeded? + (do @ + [_ (|> old + (get@ #observers) + dict;values + (mapM @ (lambda [f] (f new-value))))] + (wrap [])) + (write! new-value var)))) + +(def: #export (unfollow label target) + (All [a] (-> Text (Var a) (IO Unit))) + (do Monad<IO> + [[value observers] (atom;get target)] + (atom;set [value (dict;remove label observers)] + target))) + +(def: #export (follow label target) + {#;doc "Creates a channel (identified by a given text) that will receive all changes to the value of the given var."} + (All [a] (-> Text (Var a) (IO (frp;Chan a)))) + (let [head (frp;chan ($ 0)) + chan-var (var head) + observer (lambda [value] + (case (io;run (|> chan-var raw-read (frp;write value))) + #;None + ## By closing the output Chan, the + ## observer becomes obsolete. + (unfollow label chan-var) + + (#;Some tail') + (write! tail' chan-var)))] + (do Monad<IO> + [_ (atom;update (lambda [[value observers]] + [value (dict;put label observer observers)]) + target)] + (wrap head)))) + +(struct: #export _ (Functor STM) + (def: (map f fa) + (lambda [tx] + (let [[tx' a] (fa tx)] + [tx' (f a)])))) + +(struct: #export _ (Applicative STM) + (def: functor Functor<STM>) + + (def: (wrap a) + (lambda [tx] [tx a])) + + (def: (apply ff fa) + (lambda [tx] + (let [[tx' f] (ff tx) + [tx'' a] (fa tx')] + [tx'' (f a)])))) + +(struct: #export _ (Monad STM) + (def: applicative Applicative<STM>) + + (def: (join mma) + (lambda [tx] + (let [[tx' ma] (mma tx)] + (ma tx'))))) + +(def: #export (update! f var) + (All [a] (-> (-> a a) (Var a) (Promise [a a]))) + (promise;future (io (loop [_ []] + (let [(^@ state [value observers]) (io;run (atom;get var)) + value' (f value)] + (if (io;run (atom;compare-and-swap state + [value' observers] + var)) + [value value'] + (recur []))))))) + +(def: #export (update f var) + (All [a] (-> (-> a a) (Var a) (STM [a a]))) + (do Monad<STM> + [a (read var) + #let [a' (f a)] + _ (write a' var)] + (wrap [a a']))) + +(def: (can-commit? tx) + (-> Tx Bool) + (every? (lambda [[_var _original _current]] + (== _original (raw-read _var))) + tx)) + +(def: (commit-var [_var _original _current]) + (-> (Ex [a] (Tx-Frame a)) Unit) + (if (== _original _current) + [] + (io;run (write! _current _var)))) + +(def: fresh-tx Tx (list)) + +(def: (commit' output stm-proc) + (All [a] (-> (Promise a) (STM a) (Promise Unit))) + (promise;future (io (let [[finished-tx value] (stm-proc fresh-tx)] + (if (can-commit? finished-tx) + (exec (List/map commit-var finished-tx) + (io;run (promise;resolve value output)) + []) + (exec (commit' output stm-proc) + [])) + )))) + +(def: #export (commit stm-proc) + {#;doc "Commits a transaction and returns its result (asynchronously). + + Note that a transaction may be re-run an indeterminate number of times if other transactions involving the same variables successfully commit first. + + For this reason, it's important to note that transactions must be free from side-effects, such as I/O."} + (All [a] (-> (STM a) (Promise a))) + (let [output (promise;promise)] + (exec (commit' output stm-proc) + output))) diff --git a/stdlib/source/lux/control/applicative.lux b/stdlib/source/lux/control/applicative.lux new file mode 100644 index 000000000..5d4cad0c0 --- /dev/null +++ b/stdlib/source/lux/control/applicative.lux @@ -0,0 +1,33 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (.. ["F" functor])) + +(sig: #export (Applicative f) + (: (F;Functor f) + functor) + (: (All [a] + (-> a (f a))) + wrap) + (: (All [a b] + (-> (f (-> a b)) (f a) (f b))) + apply)) + +(def: #export (compA Applicative<F> Applicative<G>) + (All [F G] (-> (Applicative F) (Applicative G) (Applicative (All [a] (F (G a)))))) + (struct (def: functor (F;compF (get@ #functor Applicative<F>) + (get@ #functor Applicative<G>))) + (def: wrap + (|>. (:: Applicative<G> wrap) (:: Applicative<F> wrap))) + (def: (apply fgf fgx) + (let [applyF (:: Applicative<F> apply) + applyG (:: Applicative<G> apply)] + ($_ applyF + (:: Applicative<F> wrap applyG) + fgf + fgx))) + )) diff --git a/stdlib/source/lux/control/bounded.lux b/stdlib/source/lux/control/bounded.lux new file mode 100644 index 000000000..291c4d8b6 --- /dev/null +++ b/stdlib/source/lux/control/bounded.lux @@ -0,0 +1,14 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: lux) + +## Signatures +(sig: #export (Bounded a) + (: a + top) + + (: a + bottom)) diff --git a/stdlib/source/lux/control/codec.lux b/stdlib/source/lux/control/codec.lux new file mode 100644 index 000000000..e9833ccc9 --- /dev/null +++ b/stdlib/source/lux/control/codec.lux @@ -0,0 +1,28 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux control/monad + data/error)) + +## [Signatures] +(sig: #export (Codec m a) + (: (-> a m) + encode) + (: (-> m (Error a)) + decode)) + +## [Values] +(def: #export (<.> (^open "bc:") (^open "ab:")) + (All [a b c] (-> (Codec c b) (Codec b a) (Codec c a))) + (struct + (def: encode (|>. ab:encode bc:encode)) + + (def: (decode cy) + (do Monad<Error> + [by (bc:decode cy)] + (ab:decode by))) + )) diff --git a/stdlib/source/lux/control/comonad.lux b/stdlib/source/lux/control/comonad.lux new file mode 100644 index 000000000..801dbb479 --- /dev/null +++ b/stdlib/source/lux/control/comonad.lux @@ -0,0 +1,54 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + ["F" ../functor] + [lux/data/struct/list #* "" Fold<List>]) + +## [Signatures] +(sig: #export (CoMonad w) + (: (F;Functor w) + functor) + (: (All [a] + (-> (w a) a)) + unwrap) + (: (All [a] + (-> (w a) (w (w a)))) + split)) + +## [Syntax] +(macro: #export (be tokens state) + {#;doc (doc "A co-monadic parallel to the \"do\" macro." + (let [square (lambda [n] (* n n))] + (be CoMonad<Stream> + [inputs (iterate inc 2)] + (square (head inputs)))))} + (case tokens + (#;Cons comonad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil))) + (let [g!@ (: AST [["" -1 -1] (#;SymbolS ["" "@"])]) + g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])]) + g!split (: AST [["" -1 -1] (#;SymbolS ["" " split "])]) + body' (fold (: (-> [AST AST] AST AST) + (lambda [binding body'] + (let [[var value] binding] + (case var + [_ (#;TagS ["" "let"])] + (` (let (~ value) (~ body'))) + + _ + (` (|> (~ value) (~ g!split) ((~ g!map) (lambda [(~ var)] (~ body'))))) + )))) + body + (reverse (as-pairs bindings)))] + (#;Right [state (#;Cons (` (;_lux_case (~ comonad) + (~ g!@) + (;_lux_case (~ g!@) + {#functor {#F;map (~ g!map)} #unwrap (~' unwrap) #split (~ g!split)} + (~ body')))) + #;Nil)])) + + _ + (#;Left "Wrong syntax for be"))) diff --git a/stdlib/source/lux/control/effect.lux b/stdlib/source/lux/control/effect.lux new file mode 100644 index 000000000..cbd24c7f9 --- /dev/null +++ b/stdlib/source/lux/control/effect.lux @@ -0,0 +1,315 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: lux + (lux (control ["F" functor] + applicative + monad) + (codata [io #- run]) + (data (struct [list "List/" Monad<List>]) + [number "Nat/" Codec<Text,Nat>] + text/format + error) + [compiler] + [macro] + (macro [ast] + ["s" syntax #+ syntax: Syntax] + (syntax [common])) + [type] + (type ["tc" check]))) + +## [Type] +(type: #export (Eff F a) + (#Pure a) + (#Effect (F (Eff F a)))) + +(sig: #export (Handler E M) + (: (All [a] (-> (Eff E a) (M a))) + handle)) + +## [Values] +(struct: #export (Functor<Eff> dsl) + (All [F] (-> (F;Functor F) (F;Functor (Eff F)))) + (def: (map f ea) + (case ea + (#Pure a) + (#Pure (f a)) + + (#Effect value) + (#Effect (:: dsl map (map f) value))))) + +(struct: #export (Applicative<Eff> dsl) + (All [F] (-> (F;Functor F) (Applicative (Eff F)))) + (def: functor (Functor<Eff> dsl)) + + (def: (wrap a) + (#Pure a)) + + (def: (apply ef ea) + (case [ef ea] + [(#Pure f) (#Pure a)] + (#Pure (f a)) + + [(#Pure f) (#Effect fa)] + (#Effect (:: dsl map + (:: (Functor<Eff> dsl) map f) + fa)) + + [(#Effect ff) _] + (#Effect (:: dsl map + (lambda [f] (apply f ea)) + ff)) + ))) + +(struct: #export (Monad<Eff> dsl) + (All [F] (-> (F;Functor F) (Monad (Eff F)))) + (def: applicative (Applicative<Eff> dsl)) + + (def: (join efefa) + (case efefa + (#Pure efa) + (case efa + (#Pure a) + (#Pure a) + + (#Effect fa) + (#Effect fa)) + + (#Effect fefa) + (#Effect (:: dsl map + (:: (Monad<Eff> dsl) join) + fefa)) + ))) + +(type: (@| L R) + (All [a] (| (L a) (R a)))) + +(def: #export (combine-functors left right) + (All [L R] + (-> (F;Functor L) (F;Functor R) + (F;Functor (@| L R)))) + (struct + (def: (map f l|r) + (case l|r + (+0 l) (+0 (:: left map f l)) + (+1 r) (+1 (:: right map f r))) + ))) + +(def: #export (combine-handlers Monad<M> left right) + (All [L R M] + (-> (Monad M) + (Handler L M) (Handler R M) + (Handler (@| L R) M))) + (struct + (def: (handle el|r) + (case el|r + (#Pure x) + (:: Monad<M> wrap x) + + (#Effect l|r) + (case l|r + (#;Left l) (:: left handle (#Effect l)) + (#;Right r) (:: right handle (#Effect r)) + )) + ))) + +## [Syntax] +(syntax: #export (||E {effects (s;some s;any)}) + (do @ + [g!a (compiler;gensym "g!a") + #let [effects@a (List/map (lambda [eff] (` ((~ eff) (~ g!a)))) + effects)]] + (wrap (list (` (All [(~ g!a)] + (| (~@ effects@a)))) + )))) + +(syntax: #export (||F {functors (s;many s;any)}) + (wrap (list (` ($_ ;;combine-functors (~@ functors)))))) + +(syntax: #export (||H monad {handlers (s;many s;any)}) + (do @ + [g!combiner (compiler;gensym "")] + (wrap (list (` (let [(~ g!combiner) (;;combine-handlers (~ monad))] + ($_ (~ g!combiner) (~@ handlers)))))))) + +(type: Op + {#name Text + #inputs (List AST) + #output AST}) + +(def: op^ + (Syntax Op) + (s;form (s;either ($_ s;seq + s;local-symbol + (s;tuple (s;some s;any)) + s;any) + ($_ s;seq + s;local-symbol + (:: s;Monad<Syntax> wrap (list)) + s;any)))) + +(syntax: #export (effect: {exp-lvl common;export-level} + {name s;local-symbol} + {ops (s;many op^)}) + (do @ + [g!output (compiler;gensym "g!output") + #let [op-types (List/map (lambda [op] + (let [g!tag (ast;tag ["" (get@ #name op)]) + g!inputs (` [(~@ (get@ #inputs op))]) + g!output (` (-> (~ (get@ #output op)) (~ g!output)))] + (` ((~ g!tag) (~ g!inputs) (~ g!output))))) + ops) + type-name (ast;symbol ["" name]) + type-def (` (type: (~@ (common;gen-export-level exp-lvl)) + ((~ type-name) (~ g!output)) + (~@ op-types))) + op-tags (List/map (|>. (get@ #name) [""] ast;tag (list) ast;tuple) + ops) + functor-def (` (struct: (~@ (common;gen-export-level exp-lvl)) (~' _) (F;Functor (~ type-name)) + (def: ((~' map) (~' f) (~' fa)) + (case (~' fa) + (^template [(~' <tag>)] + ((~' <tag>) (~' params) (~' cont)) + ((~' <tag>) (~' params) (. (~' f) (~' cont)))) + ((~@ op-tags)))) + )) + function-defs (List/map (lambda [op] + (let [g!name (ast;symbol ["" (get@ #name op)]) + g!tag (ast;tag ["" (get@ #name op)]) + g!params (: (List AST) + (case (list;size (get@ #inputs op)) + +0 (list) + s (|> (list;range+ +0 (dec+ s)) + (List/map (|>. Nat/encode + (format "_") + [""] + ast;symbol)))))] + (` (def: (~@ (common;gen-export-level exp-lvl)) ((~ g!name) (~@ g!params)) + (-> (~@ (get@ #inputs op)) + ((~ type-name) (~ (get@ #output op)))) + ((~ g!tag) [(~@ g!params)] ;id))))) + ops)]] + (wrap (list& type-def + functor-def + function-defs)))) + +(type: Translation + {#effect Ident + #base AST + #monad AST}) + +(def: translation^ + (Syntax Translation) + (s;form (do s;Monad<Syntax> + [_ (s;symbol! ["" "=>"])] + (s;seq s;symbol + (s;tuple (s;seq s;any + s;any)))))) + +(syntax: #export (handler: {exp-lvl common;export-level} + {name s;local-symbol} + {[effect base monad] translation^} + {defs (s;many (common;def *compiler*))}) + (do @ + [(^@ effect [e-module _]) (compiler;un-alias effect) + g!input (compiler;gensym "g!input") + g!cont (compiler;gensym "g!cont") + g!value (compiler;gensym "value") + #let [g!cases (|> defs + (List/map (lambda [def] + (let [g!tag (ast;tag [e-module (get@ #common;def-name def)]) + g!args (List/map (|>. [""] ast;symbol) + (get@ #common;def-args def)) + eff-calc (case (get@ #common;def-type def) + #;None + (get@ #common;def-value def) + + (#;Some type) + (` (: (~ type) (~ (get@ #common;def-value def))))) + invocation (case g!args + #;Nil + eff-calc + + _ + (` ((~ eff-calc) (~@ g!args))))] + (list (` ((~ g!tag) [(~@ g!args)] (~ g!cont))) + (` (do (~ monad) + [(~ g!value) (~ invocation)] + ((~' handle) ((~ g!cont) (~ g!value))))) + )))) + List/join)]] + (wrap (list (` (struct: (~@ (common;gen-export-level exp-lvl)) (~ (ast;symbol ["" name])) + (;;Handler (~ (ast;symbol effect)) (~ base)) + (def: ((~' handle) (~ g!input)) + (case (~ g!input) + (#Pure (~ g!input)) + (:: (~ monad) (~' wrap) (~ g!input)) + + (#Effect (~ g!input)) + (case (~ g!input) + (~@ g!cases)))))))))) + +(syntax: #export (with-handler handler body) + (wrap (list (` (:: (~ handler) (~' handle) (~ body)))))) + +(def: (un-apply type-app) + (-> Type Type) + (case type-app + (#;AppT effect value) + effect + + _ + (error! (format "Wrong type format: " (type;type-to-text type-app))))) + +(def: (clean-effect effect) + (-> Type Type) + (case effect + (#;UnivQ env body) + (#;UnivQ (list) body) + + _ + (error! (format "Wrong effect format: " (type;type-to-text effect))))) + +(def: g!functor AST (ast;symbol ["" "%E"])) + +(syntax: #export (doE functor {bindings (s;tuple (s;some s;any))} body) + (do @ + [g!output (compiler;gensym "")] + (wrap (list (` (let [(~ g!functor) (~ functor)] + (do (Monad<Eff> (~ g!functor)) + [(~@ bindings) + (~ g!output) (~ body)] + ((~' wrap) (~ g!output))))))))) + +(syntax: #export (lift {value (s;alt s;symbol + s;any)}) + (case value + (#;Left var) + (do @ + [input (compiler;find-type var) + output compiler;expected-type] + (case [input output] + (^=> [(#;AppT eff0 _) (#;AppT stackT0 recT0)] + {(type;apply-type stackT0 recT0) (#;Some unfoldT0)} + {stackT0 (^ (#;AppT (#;NamedT (ident-for ;;Eff) _) + stackT1))} + {(type;apply-type stackT1 recT0) (#;Some unfoldT1)} + {(list;find (lambda [[idx effect]] + (if (tc;checks? (clean-effect effect) eff0) + (#;Some idx) + #;None)) + (|> unfoldT1 type;flatten-sum (List/map un-apply) list;enumerate)) + (#;Some idx)}) + (wrap (list (` (#;;Effect (:: (~ g!functor) (~' map) (~' wrap) ((~ (ast;int (nat-to-int idx))) + (~ (ast;symbol var)))))))) + + _ + (compiler;fail (format "Invalid type to lift: " (type;type-to-text output))))) + + (#;Right node) + (do @ + [g!value (compiler;gensym "")] + (wrap (list (` (let [(~ g!value) (~ node)] + (;;lift (~ g!value))))))))) diff --git a/stdlib/source/lux/control/enum.lux b/stdlib/source/lux/control/enum.lux new file mode 100644 index 000000000..63c041f95 --- /dev/null +++ b/stdlib/source/lux/control/enum.lux @@ -0,0 +1,24 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: lux + (lux/control [ord])) + +## [Signatures] +(sig: #export (Enum e) + (: (ord;Ord e) ord) + (: (-> e e) succ) + (: (-> e e) pred)) + +## [Functions] +(def: (range' <= succ from to) + (All [a] (-> (-> a a Bool) (-> a a) a a (List a))) + (if (<= to from) + (#;Cons from (range' <= succ (succ from) to)) + #;Nil)) + +(def: #export (range (^open) from to) + (All [a] (-> (Enum a) a a (List a))) + (range' <= succ from to)) diff --git a/stdlib/source/lux/control/eq.lux b/stdlib/source/lux/control/eq.lux new file mode 100644 index 000000000..357780fcd --- /dev/null +++ b/stdlib/source/lux/control/eq.lux @@ -0,0 +1,29 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: lux) + +(sig: #export (Eq a) + (: (-> a a Bool) + =)) + +(def: #export (conj left right) + (All [l r] (-> (Eq l) (Eq r) (Eq [l r]))) + (struct (def: (= [a b] [x y]) + (and (:: left = a x) + (:: right = b y))))) + +(def: #export (disj left right) + (All [l r] (-> (Eq l) (Eq r) (Eq (| l r)))) + (struct (def: (= a|b x|y) + (case [a|b x|y] + [(+0 a) (+0 x)] + (:: left = a x) + + [(+1 b) (+1 y)] + (:: right = b y) + + _ + false)))) diff --git a/stdlib/source/lux/control/fold.lux b/stdlib/source/lux/control/fold.lux new file mode 100644 index 000000000..6e56dacee --- /dev/null +++ b/stdlib/source/lux/control/fold.lux @@ -0,0 +1,12 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: lux) + +## [Signatures] +(sig: #export (Fold F) + (: (All [a b] + (-> (-> b a a) a (F b) a)) + fold)) diff --git a/stdlib/source/lux/control/functor.lux b/stdlib/source/lux/control/functor.lux new file mode 100644 index 000000000..711c5ae16 --- /dev/null +++ b/stdlib/source/lux/control/functor.lux @@ -0,0 +1,16 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: lux) + +(sig: #export (Functor f) + (: (All [a b] + (-> (-> a b) (f a) (f b))) + map)) + +(def: #export (compF Functor<F> Functor<G>) + (All [F G] (-> (Functor F) (Functor G) (Functor (All [a] (F (G a)))))) + (struct (def: (map f fga) + (:: Functor<F> map (:: Functor<G> map f) fga)))) diff --git a/stdlib/source/lux/control/hash.lux b/stdlib/source/lux/control/hash.lux new file mode 100644 index 000000000..d8ae926ad --- /dev/null +++ b/stdlib/source/lux/control/hash.lux @@ -0,0 +1,15 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (.. eq)) + +## [Signatures] +(sig: #export (Hash a) + (: (Eq a) + eq) + (: (-> a Nat) + hash)) diff --git a/stdlib/source/lux/control/monad.lux b/stdlib/source/lux/control/monad.lux new file mode 100644 index 000000000..71a873704 --- /dev/null +++ b/stdlib/source/lux/control/monad.lux @@ -0,0 +1,142 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (.. (functor #as F) + (applicative #as A))) + +## [Utils] +(def: (fold f init xs) + (All [a b] + (-> (-> b a a) a (List b) a)) + (case xs + #;Nil + init + + (#;Cons x xs') + (fold f (f x init) xs'))) + +(def: (map f xs) + (All [a b] + (-> (-> a b) (List a) (List b))) + (case xs + #;Nil + #;Nil + + (#;Cons x xs') + (#;Cons (f x) (map f xs')))) + +(def: (reverse xs) + (All [a] + (-> (List a) (List a))) + (fold (lambda [head tail] (#;Cons head tail)) + #;Nil + xs)) + +(def: (as-pairs xs) + (All [a] (-> (List a) (List [a a]))) + (case xs + (#;Cons x1 (#;Cons x2 xs')) + (#;Cons [x1 x2] (as-pairs xs')) + + _ + #;Nil)) + +## [Signatures] +(sig: #export (Monad m) + (: (A;Applicative m) + applicative) + (: (All [a] + (-> (m (m a)) (m a))) + join)) + +## [Syntax] +(macro: #export (do tokens state) + {#;doc (doc "Macro for easy concatenation of monadic operations." + (do Monad<Maybe> + [y (f1 x) + z (f2 z)] + (wrap (f3 z))))} + (case tokens + (#;Cons monad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil))) + (let [g!@ (: AST [["" -1 -1] (#;SymbolS ["" "@"])]) + g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])]) + g!join (: AST [["" -1 -1] (#;SymbolS ["" " join "])]) + g!apply (: AST [["" -1 -1] (#;SymbolS ["" " apply "])]) + body' (fold (: (-> [AST AST] AST AST) + (lambda [binding body'] + (let [[var value] binding] + (case var + [_ (#;TagS ["" "let"])] + (` (let (~ value) (~ body'))) + + _ + (` (|> (~ value) ((~ g!map) (lambda [(~ var)] (~ body'))) (~ g!join))) + )))) + body + (reverse (as-pairs bindings)))] + (#;Right [state (#;Cons (` (;_lux_case (~ monad) + (~ g!@) + (;_lux_case (~ g!@) + {#applicative {#A;functor {#F;map (~ g!map)} + #A;wrap (~' wrap) + #A;apply (~ g!apply)} + #join (~ g!join)} + (~ body')))) + #;Nil)])) + + _ + (#;Left "Wrong syntax for do"))) + +## [Functions] +(def: #export (seqM monad xs) + (All [M a] + (-> (Monad M) (List (M a)) (M (List a)))) + (case xs + #;Nil + (:: monad wrap #;Nil) + + (#;Cons x xs') + (do monad + [_x x + _xs (seqM monad xs')] + (wrap (#;Cons _x _xs))) + )) + +(def: #export (mapM monad f xs) + (All [M a b] + (-> (Monad M) (-> a (M b)) (List a) (M (List b)))) + (case xs + #;Nil + (:: monad wrap #;Nil) + + (#;Cons x xs') + (do monad + [_x (f x) + _xs (mapM monad f xs')] + (wrap (#;Cons _x _xs))) + )) + +(def: #export (foldM monad f init xs) + (All [M a b] + (-> (Monad M) (-> b a (M a)) a (List b) + (M a))) + (case xs + #;Nil + (:: monad wrap init) + + (#;Cons x xs') + (do monad + [init' (f x init)] + (foldM monad f init' xs')))) + +(def: #export (liftM Monad<M> f) + (All [M a b] + (-> (Monad M) (-> a b) (-> (M a) (M b)))) + (lambda [ma] + (do Monad<M> + [a ma] + (wrap (f a))))) diff --git a/stdlib/source/lux/control/monoid.lux b/stdlib/source/lux/control/monoid.lux new file mode 100644 index 000000000..67f6d868c --- /dev/null +++ b/stdlib/source/lux/control/monoid.lux @@ -0,0 +1,13 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: lux) + +## Signatures +(sig: #export (Monoid a) + (: a + unit) + (: (-> a a a) + append)) diff --git a/stdlib/source/lux/control/number.lux b/stdlib/source/lux/control/number.lux new file mode 100644 index 000000000..d6e9a42b6 --- /dev/null +++ b/stdlib/source/lux/control/number.lux @@ -0,0 +1,22 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux/control [ord])) + +## [Signatures] +(sig: #export (Number n) + (: (ord;Ord n) + ord) + + (do-template [<name>] + [(: (-> n n n) <name>)] + [+] [-] [*] [/] [%]) + + (do-template [<name>] + [(: (-> n n) <name>)] + [negate] [signum] [abs]) + ) diff --git a/stdlib/source/lux/control/ord.lux b/stdlib/source/lux/control/ord.lux new file mode 100644 index 000000000..0021cbe1b --- /dev/null +++ b/stdlib/source/lux/control/ord.lux @@ -0,0 +1,44 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + [lux #- min max] + (.. eq) + lux/codata/function) + +## [Signatures] +(sig: #export (Ord a) + (: (Eq a) + eq) + + (do-template [<name>] + [(: (-> a a Bool) <name>)] + + [<] [<=] [>] [>=])) + +## [Values] +(def: #export (ord eq <) + (All [a] + (-> (Eq a) (-> a a Bool) (Ord a))) + (let [> (flip <)] + (struct + (def: eq eq) + (def: < <) + (def: (<= test subject) + (or (< test subject) + (:: eq = test subject))) + (def: > >) + (def: (>= test subject) + (or (> test subject) + (:: eq = test subject)))))) + +(do-template [<name> <op>] + [(def: #export (<name> ord x y) + (All [a] + (-> (Ord a) a a a)) + (if (:: ord <op> y x) x y))] + + [max >] + [min <]) diff --git a/stdlib/source/lux/data/bit.lux b/stdlib/source/lux/data/bit.lux new file mode 100644 index 000000000..72a92507c --- /dev/null +++ b/stdlib/source/lux/data/bit.lux @@ -0,0 +1,66 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: [lux #- & | ^]) + +## [Values] +(do-template [<short-name> <op> <doc> <type>] + [(def: #export (<short-name> param subject) + {#;doc <doc>} + (-> Nat <type> <type>) + (_lux_proc ["bit" <op>] [subject param]))] + + [& "and" "Bit and." Nat] + [| "or" "Bit or." Nat] + [^ "xor" "Bit xor." Nat] + [<< "shift-left" "Bit shift-left." Nat] + [>> "shift-right" "Bit shift-right." Int] + [>>> "unsigned-shift-right" "Bit unsigned-shift-right." Nat] + ) + +(def: #export (count subject) + {#;doc "Count the number of 1s in a bit-map."} + (-> Nat Nat) + (_lux_proc ["bit" "count"] [subject])) + +(def: mask Nat (int-to-nat -1)) + +(def: #export ~ + {#;doc "Bit negation."} + (-> Nat Nat) + (^ mask)) + +(def: #export (clear idx input) + {#;doc "Clear bit at given index."} + (-> Nat Nat Nat) + (& (~ (<< idx +1)) input)) + +(do-template [<name> <op> <doc>] + [(def: #export (<name> idx input) + {#;doc <doc>} + (-> Nat Nat Nat) + (<op> (<< idx +1) input))] + + [set | "Set bit at given index."] + [flip ^ "Flip bit at given index."] + ) + +(def: #export (set? idx input) + (-> Nat Nat Bool) + (|> input (& (<< idx +1)) (=+ +0) not)) + +(def: rot-top Nat +64) + +(do-template [<name> <main> <comp>] + [(def: #export (<name> distance input) + (-> Nat Nat Nat) + (| (<main> distance input) + (<comp> (-+ (%+ rot-top distance) + rot-top) + input)))] + + [rotate-left << >>>] + [rotate-right >>> <<] + ) diff --git a/stdlib/source/lux/data/bool.lux b/stdlib/source/lux/data/bool.lux new file mode 100644 index 000000000..15dc349ef --- /dev/null +++ b/stdlib/source/lux/data/bool.lux @@ -0,0 +1,47 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monoid + eq + codec) + (codata function))) + +## [Structures] +(struct: #export _ (Eq Bool) + (def: (= x y) + (if x + y + (not y)))) + +(do-template [<name> <unit> <op>] + [(struct: #export <name> (Monoid Bool) + (def: unit <unit>) + (def: (append x y) + (<op> x y)))] + + [ Or@Monoid<Bool> false or] + [And@Monoid<Bool> true and] + ) + +(struct: #export _ (Codec Text Bool) + (def: (encode x) + (if x + "true" + "false")) + + (def: (decode input) + (case input + "true" (#;Right true) + "false" (#;Right false) + _ (#;Left "Wrong syntax for Bool.")))) + +## [Values] +(def: #export complement + {#;doc "Generates the complement of a predicate. + That is a predicate that returns the oposite of the original predicate."} + (All [a] (-> (-> a Bool) (-> a Bool))) + (. not)) diff --git a/stdlib/source/lux/data/char.lux b/stdlib/source/lux/data/char.lux new file mode 100644 index 000000000..6af987408 --- /dev/null +++ b/stdlib/source/lux/data/char.lux @@ -0,0 +1,107 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux/control eq + [ord] + codec + hash) + (.. [text "Text/" Monoid<Text>])) + +## [Structures] +(struct: #export _ (Eq Char) + (def: (= x y) + (_lux_proc ["jvm" "ceq"] [x y]))) + +(struct: #export _ (Hash Char) + (def: eq Eq<Char>) + (def: hash + (|>. [] + (_lux_proc ["jvm" "c2i"]) + [] + (_lux_proc ["jvm" "i2l"]) + int-to-nat))) + +(struct: #export _ (ord;Ord Char) + (def: eq Eq<Char>) + + (do-template [<name> <op>] + [(def: (<name> test subject) + (_lux_proc ["jvm" <op>] [subject test]))] + + [< "clt"] + [> "cgt"] + ) + + (do-template [<name> <op>] + [(def: (<name> test subject) + (or (_lux_proc ["jvm" "ceq"] [subject test]) + (_lux_proc ["jvm" <op>] [subject test])))] + + [<= "clt"] + [>= "cgt"] + )) + +(struct: #export _ (Codec Text Char) + (def: (encode x) + (let [as-text (case x + #"\t" "\\t" + #"\b" "\\b" + #"\n" "\\n" + #"\r" "\\r" + #"\f" "\\f" + #"\"" "\\\"" + #"\\" "\\\\" + _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))] + ($_ Text/append "#\"" as-text "\""))) + + (def: (decode y) + (let [size (text;size y)] + (if (and (text;starts-with? "#\"" y) + (text;ends-with? "\"" y) + (or (=+ +4 size) + (=+ +5 size))) + (if (=+ +4 size) + (case (text;at +2 y) + #;None + (#;Left (Text/append "Wrong syntax for Char: " y)) + + (#;Some char) + (#;Right char)) + (case [(text;at +2 y) (text;at +3 y)] + [(#;Some #"\\") (#;Some char)] + (case char + #"t" (#;Right #"\t") + #"b" (#;Right #"\b") + #"n" (#;Right #"\n") + #"r" (#;Right #"\r") + #"f" (#;Right #"\f") + #"\"" (#;Right #"\"") + #"\\" (#;Right #"\\") + #"t" (#;Right #"\t") + _ (#;Left (Text/append "Wrong syntax for Char: " y))) + + _ + (#;Left (Text/append "Wrong syntax for Char: " y)))) + (#;Left (Text/append "Wrong syntax for Char: " y)))))) + +## [Values] +(def: #export (space? x) + {#;doc "Checks whether the character is white-space."} + (-> Char Bool) + (_lux_proc ["jvm" "invokestatic:java.lang.Character:isWhitespace:char"] [x])) + +(def: #export (as-text x) + (-> Char Text) + (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x])) + +(def: #export (char x) + (-> Nat Char) + (_lux_proc ["nat" "to-char"] [x])) + +(def: #export (code x) + (-> Char Nat) + (_lux_proc ["char" "to-nat"] [x])) diff --git a/stdlib/source/lux/data/error.lux b/stdlib/source/lux/data/error.lux new file mode 100644 index 000000000..ce2f529b9 --- /dev/null +++ b/stdlib/source/lux/data/error.lux @@ -0,0 +1,66 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + applicative + ["M" monad #*]))) + +## [Types] +(type: #export (Error a) + (Either Text a)) + +## [Structures] +(struct: #export _ (Functor Error) + (def: (map f ma) + (case ma + (#;Left msg) (#;Left msg) + (#;Right datum) (#;Right (f datum))))) + +(struct: #export _ (Applicative Error) + (def: functor Functor<Error>) + + (def: (wrap a) + (#;Right a)) + + (def: (apply ff fa) + (case ff + (#;Right f) + (case fa + (#;Right a) + (#;Right (f a)) + + (#;Left msg) + (#;Left msg)) + + (#;Left msg) + (#;Left msg)) + )) + +(struct: #export _ (Monad Error) + (def: applicative Applicative<Error>) + + (def: (join mma) + (case mma + (#;Left msg) (#;Left msg) + (#;Right ma) ma))) + +(struct: #export (ErrorT Monad<M>) + (All [M] (-> (Monad M) (Monad (All [a] (M (Error a)))))) + (def: applicative (compA (get@ #M;applicative Monad<M>) Applicative<Error>)) + (def: (join MeMea) + (do Monad<M> + [eMea MeMea] + (case eMea + (#;Left error) + (wrap (#;Left error)) + + (#;Right Mea) + (join Mea))))) + +(def: #export (lift-error Monad<M>) + (All [M a] (-> (Monad M) (-> (M a) (M (Error a))))) + (liftM Monad<M> (:: Monad<Error> wrap))) diff --git a/stdlib/source/lux/data/error/exception.lux b/stdlib/source/lux/data/error/exception.lux new file mode 100644 index 000000000..be9a09327 --- /dev/null +++ b/stdlib/source/lux/data/error/exception.lux @@ -0,0 +1,62 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monad) + (data error + [text]) + [compiler] + (macro [ast] + ["s" syntax #+ syntax: Syntax] + (syntax [common])))) + +## [Types] +(type: #export Exception + (-> Text Text)) + +## [Values] +(def: #hidden _Text/append_ + (-> Text Text Text) + (:: text;Monoid<Text> append)) + +(def: #export (catch exception then try) + (All [a] + (-> Exception (-> Text a) (Error a) + (Error a))) + (case try + (#;Right output) + (#;Right output) + + (#;Left error) + (if (text;starts-with? (exception "") error) + (#;Right (then error)) + (#;Left error)))) + +(def: #export (else to-do try) + (All [a] + (-> (-> Text a) (Error a) a)) + (case try + (#;Right output) + output + + (#;Left error) + (to-do error))) + +(def: #export (return value) + (All [a] (-> a (Error a))) + (#;Right value)) + +(def: #export (throw exception message) + (All [a] (-> Exception Text (Error a))) + (#;Left (exception message))) + +(syntax: #export (exception: {_ex-lev common;export-level} {name s;local-symbol}) + (do @ + [current-module compiler;current-module-name + #let [g!message (ast;symbol ["" "message"])]] + (wrap (list (` (def: (~@ (common;gen-export-level _ex-lev)) ((~ (ast;symbol ["" name])) (~ g!message)) + Exception + ($_ _Text/append_ "[" (~ (ast;text current-module)) ";" (~ (ast;text name)) "]\t" (~ g!message)))))))) diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux new file mode 100644 index 000000000..c51e4b04c --- /dev/null +++ b/stdlib/source/lux/data/format/json.lux @@ -0,0 +1,1031 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + applicative + monad + eq + codec) + (data [bool] + [text "Text/" Eq<Text> Monoid<Text>] + text/format + [number #* "Real/" Codec<Text,Real>] + maybe + [char "Char/" Eq<Char> Codec<Text,Char>] + error + [sum] + [product] + (struct [list "" Fold<List> "List/" Monad<List>] + [vector #+ Vector vector "Vector/" Monad<Vector>] + [dict #+ Dict])) + (codata [function]) + [compiler #+ Monad<Lux> with-gensyms] + (macro [syntax #+ syntax:] + [ast] + [poly #+ poly:]) + [type] + [lexer #+ Lexer Monad<Lexer>])) + +## [Types] +(do-template [<name> <type>] + [(type: #export <name> <type>)] + + [Null Unit] + [Boolean Bool] + [Number Real] + [String Text] + ) + +(type: #export #rec JSON + (#Null Null) + (#Boolean Boolean) + (#Number Number) + (#String String) + (#Array (Vector JSON)) + (#Object (Dict String JSON))) + +(do-template [<name> <type>] + [(type: #export <name> <type>)] + + [Array (Vector JSON)] + [Object (Dict String JSON)] + ) + +(type: #export (Parser a) + (-> JSON (Error a))) + +(type: #export (Gen a) + (-> a JSON)) + +## [Syntax] +(syntax: #export (json token) + (let [(^open) Monad<Lux> + wrapper (lambda [x] (` (;;json (~ x))))] + (case token + (^template [<ast-tag> <ctor> <json-tag>] + [_ (<ast-tag> value)] + (wrap (list (` (: JSON (<json-tag> (~ (<ctor> value)))))))) + ([#;BoolS ast;bool #Boolean] + [#;IntS (|>. int-to-real ast;real) #Number] + [#;RealS ast;real #Number] + [#;TextS ast;text #String]) + + [_ (#;TagS ["" "null"])] + (wrap (list (` (: JSON #Null)))) + + [_ (#;TupleS members)] + (wrap (list (` (: JSON (#Array (vector (~@ (List/map wrapper members)))))))) + + [_ (#;RecordS pairs)] + (do Monad<Lux> + [pairs' (mapM @ + (lambda [[slot value]] + (case slot + [_ (#;TextS key-name)] + (wrap (` [(~ (ast;text key-name)) (~ (wrapper value))])) + + _ + (compiler;fail "Wrong syntax for JSON object."))) + pairs)] + (wrap (list (` (: JSON (#Object (dict;from-list text;Hash<Text> (list (~@ pairs'))))))))) + + _ + (wrap (list token)) + ))) + +## [Values] +(def: #hidden (show-null _) (-> Null Text) "null") +(do-template [<name> <type> <codec>] + [(def: <name> (-> <type> Text) (:: <codec> encode))] + + [show-boolean Boolean bool;Codec<Text,Bool>] + [show-number Number number;Codec<Text,Real>] + [show-string String text;Codec<Text,Text>]) + +(def: (show-array show-json elems) + (-> (-> JSON Text) (-> Array Text)) + (format "[" + (|> elems (Vector/map show-json) vector;vector-to-list (text;join-with ",")) + "]")) + +(def: (show-object show-json object) + (-> (-> JSON Text) (-> Object Text)) + (format "{" + (|> object + dict;entries + (List/map (lambda [[key value]] (format (:: text;Codec<Text,Text> encode key) ":" (show-json value)))) + (text;join-with ",")) + "}")) + +(def: (show-json json) + (-> JSON Text) + (case json + (^template [<tag> <show>] + (<tag> value) + (<show> value)) + ([#Null show-null] + [#Boolean show-boolean] + [#Number show-number] + [#String show-string] + [#Array (show-array show-json)] + [#Object (show-object show-json)]) + )) + +(def: #export null + JSON + #Null) + +(def: #export (keys json) + (-> JSON (Error (List String))) + (case json + (#Object obj) + (#;Right (dict;keys obj)) + + _ + (#;Left (format "Can't get keys of a non-object.")))) + +(def: #export (get key json) + (-> String JSON (Error JSON)) + (case json + (#Object obj) + (case (dict;get key obj) + (#;Some value) + (#;Right value) + + #;None + (#;Left (format "Missing field " (show-string key) " on object."))) + + _ + (#;Left (format "Can't get field " (show-string key) " of a non-object.")))) + +(def: #export (set key value json) + (-> String JSON JSON (Error JSON)) + (case json + (#Object obj) + (#;Right (#Object (dict;put key value obj))) + + _ + (#;Left (format "Can't set field " (show-string key) " of a non-object.")))) + +(do-template [<name> <tag> <type>] + [(def: #export (<name> key json) + (-> Text JSON (Error <type>)) + (case (get key json) + (#;Right (<tag> value)) + (#;Right value) + + (#;Right _) + (#;Left (format "Wrong value type at key " (show-string key))) + + (#;Left error) + (#;Left error)))] + + [get-boolean #Boolean Boolean] + [get-number #Number Number] + [get-string #String String] + [get-array #Array Array] + [get-object #Object Object] + ) + +(do-template [<name> <type> <tag>] + [(def: #export (<name> value) + (Gen <type>) + (<tag> value))] + + [gen-boolean Boolean #Boolean] + [gen-number Number #Number] + [gen-string String #String] + [gen-array Array #Array] + [gen-object Object #Object] + ) + +(def: #export (gen-nullable gen) + (All [a] (-> (Gen a) (Gen (Maybe a)))) + (lambda [elem] + (case elem + #;None #Null + (#;Some value) (gen value)))) + +## Lexers +(def: space~ + (Lexer Text) + (lexer;some' lexer;space)) + +(def: data-sep + (Lexer [Text Char Text]) + ($_ lexer;seq space~ (lexer;this-char #",") space~)) + +(def: null~ + (Lexer Null) + (do Monad<Lexer> + [_ (lexer;this "null")] + (wrap []))) + +(do-template [<name> <token> <value>] + [(def: <name> + (Lexer Boolean) + (do Monad<Lexer> + [_ (lexer;this <token>)] + (wrap <value>)))] + + [t~ "true" true] + [f~ "false" false] + ) + +(def: boolean~ + (Lexer Boolean) + (lexer;either t~ f~)) + +(def: number~ + (Lexer Number) + (do Monad<Lexer> + [?sign (: (Lexer (Maybe Text)) + (lexer;opt (lexer;this "-"))) + digits (: (Lexer Text) + (lexer;many' lexer;digit)) + ?decimals (: (Lexer (Maybe Text)) + (lexer;opt (do @ + [_ (lexer;this ".")] + (lexer;many' lexer;digit))))] + (case (: (Error Real) + (Real/decode (format (default "" ?sign) + digits "." + (default "0" ?decimals)))) + (#;Left message) + (lexer;fail message) + + (#;Right value) + (wrap value)))) + +(def: (un-escape escaped) + (-> Char Text) + (case escaped + #"t" "\t" + #"b" "\b" + #"n" "\n" + #"r" "\r" + #"f" "\f" + #"\"" "\"" + #"\\" "\\" + _ "")) + +(def: string-body~ + (Lexer Text) + (loop [_ []] + (do Monad<Lexer> + [chars (lexer;some' (lexer;none-of "\\\"")) + stop-char lexer;peek] + (if (Char/= #"\\" stop-char) + (do @ + [_ lexer;any + escaped lexer;any + next-chars (recur [])] + (wrap (format chars (un-escape escaped) next-chars))) + (wrap chars))))) + +(def: string~ + (Lexer String) + (do Monad<Lexer> + [_ (lexer;this "\"") + string-body string-body~ + _ (lexer;this "\"")] + (wrap string-body))) + +(def: (kv~ json~) + (-> (-> Unit (Lexer JSON)) (Lexer [String JSON])) + (do Monad<Lexer> + [key string~ + _ space~ + _ (lexer;this-char #":") + _ space~ + value (json~ [])] + (wrap [key value]))) + +(do-template [<name> <type> <open> <close> <elem-parser> <prep>] + [(def: (<name> json~) + (-> (-> Unit (Lexer JSON)) (Lexer <type>)) + (do Monad<Lexer> + [_ (lexer;this-char <open>) + _ space~ + elems (lexer;sep-by data-sep <elem-parser>) + _ space~ + _ (lexer;this-char <close>)] + (wrap (<prep> elems))))] + + [array~ Array #"[" #"]" (json~ []) vector;list-to-vector] + [object~ Object #"{" #"}" (kv~ json~) (dict;from-list text;Hash<Text>)] + ) + +(def: (json~' _) + (-> Unit (Lexer JSON)) + ($_ lexer;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~'))) + +## [Structures] +(struct: #export _ (Functor Parser) + (def: (map f ma) + (lambda [json] + (case (ma json) + (#;Left msg) + (#;Left msg) + + (#;Right a) + (#;Right (f a)))))) + +(struct: #export _ (Applicative Parser) + (def: functor Functor<Parser>) + + (def: (wrap x json) + (#;Right x)) + + (def: (apply ff fa) + (lambda [json] + (case (ff json) + (#;Right f) + (case (fa json) + (#;Right a) + (#;Right (f a)) + + (#;Left msg) + (#;Left msg)) + + (#;Left msg) + (#;Left msg))))) + +(struct: #export _ (Monad Parser) + (def: applicative Applicative<Parser>) + + (def: (join mma) + (lambda [json] + (case (mma json) + (#;Left msg) + (#;Left msg) + + (#;Right ma) + (ma json))))) + +## [Values] +## Syntax +(do-template [<name> <type> <tag> <desc> <pre>] + [(def: #export (<name> json) + (Parser <type>) + (case json + (<tag> value) + (#;Right (<pre> value)) + + _ + (#;Left (format "JSON value is not a " <desc> ": " (show-json json)))))] + + [unit Unit #Null "null" id] + [bool Bool #Boolean "boolean" id] + [int Int #Number "number" real-to-int] + [real Real #Number "number" id] + [text Text #String "string" id] + ) + +(do-template [<test> <check> <type> <eq> <codec> <tag> <desc> <pre>] + [(def: #export (<test> test json) + (-> <type> (Parser Bool)) + (case json + (<tag> value) + (#;Right (:: <eq> = test (<pre> value))) + + _ + (#;Left (format "JSON value is not a " <desc> ": " (show-json json))))) + + (def: #export (<check> test json) + (-> <type> (Parser Unit)) + (case json + (<tag> value) + (let [value (<pre> value)] + (if (:: <eq> = test value) + (#;Right []) + (#;Left (format "Value mismatch: " + (:: <codec> encode test) "=/=" (:: <codec> encode value))))) + + _ + (#;Left (format "JSON value is not a " <desc> ": " (show-json json)))))] + + [bool? bool! Bool bool;Eq<Bool> bool;Codec<Text,Bool> #Boolean "boolean" id] + [int? int! Int number;Eq<Int> number;Codec<Text,Int> #Number "number" real-to-int] + [real? real! Real number;Eq<Real> number;Codec<Text,Real> #Number "number" id] + [text? text! Text text;Eq<Text> text;Codec<Text,Text> #String "string" id] + ) + +(def: #export (char json) + (Parser Char) + (case json + (#String input) + (case (Char/decode (format "#\"" input "\"")) + (#;Right value) + (#;Right value) + + (#;Left _) + (#;Left (format "Invalid format for char: " input))) + + _ + (#;Left (format "JSON value is not a " "string" ": " (show-json json))))) + +(def: #export (char? test json) + (-> Char (Parser Bool)) + (case json + (#String input) + (case (Char/decode (format "#\"" input "\"")) + (#;Right value) + (if (:: char;Eq<Char> = test value) + (#;Right true) + (#;Left (format "Value mismatch: " + (:: char;Codec<Text,Char> encode test) "=/=" (:: char;Codec<Text,Char> encode value)))) + + (#;Left _) + (#;Left (format "Invalid format for char: " input))) + + _ + (#;Left (format "JSON value is not a " "string" ": " (show-json json))))) + +(def: #export (char! test json) + (-> Char (Parser Unit)) + (case json + (#String input) + (case (Char/decode (format "#\"" input "\"")) + (#;Right value) + (if (:: char;Eq<Char> = test value) + (#;Right []) + (#;Left (format "Value mismatch: " + (:: char;Codec<Text,Char> encode test) "=/=" (:: char;Codec<Text,Char> encode value)))) + + (#;Left _) + (#;Left (format "Invalid format for char: " input))) + + _ + (#;Left (format "JSON value is not a " "string" ": " (show-json json))))) + +(def: #export (nullable parser) + (All [a] (-> (Parser a) (Parser (Maybe a)))) + (lambda [json] + (case json + #Null + (#;Right #;None) + + _ + (case (parser json) + (#;Left error) + (#;Left error) + + (#;Right value) + (#;Right (#;Some value))) + ))) + +(def: #export (array parser) + (All [a] (-> (Parser a) (Parser (List a)))) + (lambda [json] + (case json + (#Array values) + (do Monad<Error> + [elems (mapM @ parser (vector;vector-to-list values))] + (wrap elems)) + + _ + (#;Left (format "JSON value is not an array: " (show-json json)))))) + +(def: #export (object parser) + (All [a] (-> (Parser a) (Parser (Dict String a)))) + (lambda [json] + (case json + (#Object fields) + (do Monad<Error> + [kvs (mapM @ + (lambda [[key val']] + (do @ + [val (parser val')] + (wrap [key val]))) + (dict;entries fields))] + (wrap (dict;from-list text;Hash<Text> kvs))) + + _ + (#;Left (format "JSON value is not an object: " (show-json json)))))) + +(def: #export (at idx parser) + (All [a] (-> Nat (Parser a) (Parser a))) + (lambda [json] + (case json + (#Array values) + (case (vector;at idx values) + (#;Some value) + (case (parser value) + (#;Right output) + (#;Right output) + + (#;Left error) + (#;Left (format "JSON array index [" (%n idx) "]: (" error ") @ " (show-json json)))) + + #;None + (#;Left (format "JSON array does not have index " (%n idx) " @ " (show-json json)))) + + _ + (#;Left (format "JSON value is not an array: " (show-json json)))))) + +(def: #export (field field-name parser) + (All [a] (-> Text (Parser a) (Parser a))) + (lambda [json] + (case (get field-name json) + (#;Some value) + (case (parser value) + (#;Right output) + (#;Right output) + + (#;Left error) + (#;Left (format "Failed to get JSON object field " (show-string field-name) ": (" error ") @ " (show-json json)))) + + (#;Left _) + (#;Left (format "JSON object does not have field " (show-string field-name) " @ " (show-json json)))))) + +(def: #export any + (Parser JSON) + (lambda [json] + (#;Right json))) + +(def: #export (seq pa pb) + (All [a b] (-> (Parser a) (Parser b) (Parser [a b]))) + (do Monad<Parser> + [=a pa + =b pb] + (wrap [=a =b]))) + +(def: #export (alt pa pb json) + (All [a b] (-> (Parser a) (Parser b) (Parser (| a b)))) + (case (pa json) + (#;Right a) + (sum;right (sum;left a)) + + (#;Left message0) + (case (pb json) + (#;Right b) + (sum;right (sum;right b)) + + (#;Left message1) + (#;Left message0)))) + +(def: #export (either pl pr json) + (All [a] (-> (Parser a) (Parser a) (Parser a))) + (case (pl json) + (#;Right x) + (#;Right x) + + _ + (pr json))) + +(def: #export (opt p json) + (All [a] + (-> (Parser a) (Parser (Maybe a)))) + (case (p json) + (#;Left _) (#;Right #;None) + (#;Right x) (#;Right (#;Some x)))) + +(def: #export (run parser json) + (All [a] (-> (Parser a) JSON (Error a))) + (parser json)) + +(def: #export (ensure test parser json) + (All [a] (-> (Parser Unit) (Parser a) (Parser a))) + (case (test json) + (#;Right _) + (parser json) + + (#;Left error) + (#;Left error))) + +(def: #export (array-size! array-size json) + (-> Nat (Parser Unit)) + (case json + (#Array parts) + (if (=+ array-size (vector;size parts)) + (#;Right []) + (#;Left (format "JSON array does no have size " (%n array-size) " " (show-json json)))) + + _ + (#;Left (format "JSON value is not an array: " (show-json json))))) + +(def: #export (object-fields! wanted-fields json) + (-> (List String) (Parser Unit)) + (case json + (#Object kvs) + (let [actual-fields (dict;keys kvs)] + (if (and (=+ (list;size wanted-fields) (list;size actual-fields)) + (list;every? (list;member? text;Eq<Text> wanted-fields) + actual-fields)) + (#;Right []) + (#;Left (format "JSON object has wrong field-set. Expected: [" (text;join-with ", " wanted-fields) "]. Actual: [" (text;join-with ", " actual-fields) "]")))) + + _ + (#;Left (format "JSON value is not an object: " (show-json json))))) + +## [Structures] +(struct: #export _ (Eq JSON) + (def: (= x y) + (case [x y] + [#Null #Null] + true + + (^template [<tag> <struct>] + [(<tag> x') (<tag> y')] + (:: <struct> = x' y')) + ([#Boolean bool;Eq<Bool>] + [#Number number;Eq<Real>] + [#String text;Eq<Text>]) + + [(#Array xs) (#Array ys)] + (and (=+ (vector;size xs) (vector;size ys)) + (fold (lambda [idx prev] + (and prev + (default false + (do Monad<Maybe> + [x' (vector;at idx xs) + y' (vector;at idx ys)] + (wrap (= x' y')))))) + true + (list;indices (vector;size xs)))) + + [(#Object xs) (#Object ys)] + (and (=+ (dict;size xs) (dict;size ys)) + (fold (lambda [[xk xv] prev] + (and prev + (case (dict;get xk ys) + #;None false + (#;Some yv) (= xv yv)))) + true + (dict;entries xs))) + + _ + false))) + +(struct: #export _ (Codec Text JSON) + (def: encode show-json) + (def: decode (lexer;run (json~' [])))) + +## [Syntax] +(type: Shape + (#ArrayShape (List AST)) + (#ObjectShape (List [Text AST]))) + +(def: _shape^ + (syntax;Syntax Shape) + (syntax;alt (syntax;tuple (syntax;some syntax;any)) + (syntax;record (syntax;some (syntax;seq syntax;text syntax;any))))) + +(syntax: #export (shape^ {shape _shape^}) + (case shape + (#ArrayShape parts) + (let [array-size (list;size parts) + parsers (|> parts + (list;zip2 (list;indices array-size)) + (List/map (lambda [[idx parser]] + (` (at (~ (ast;nat idx)) (~ parser))))))] + (wrap (list (` ($_ seq (~@ parsers)))))) + + (#ObjectShape kvs) + (let [fields (List/map product;left kvs) + parsers (List/map (lambda [[field-name parser]] + (` (field (~ (ast;text field-name)) (~ parser)))) + kvs)] + (wrap (list (` ($_ seq (~@ parsers)))))) + )) + +(syntax: #export (shape!^ {shape _shape^}) + (case shape + (#ArrayShape parts) + (let [array-size (list;size parts) + parsers (|> parts + (list;zip2 (list;indices array-size)) + (List/map (lambda [[idx parser]] + (` (at (~ (ast;nat idx)) (~ parser))))))] + (wrap (list (` (ensure (array-size! (~ (ast;nat array-size))) + ($_ seq (~@ parsers))))))) + + (#ObjectShape kvs) + (let [fields (List/map product;left kvs) + parsers (List/map (lambda [[field-name parser]] + (` (field (~ (ast;text field-name)) (~ parser)))) + kvs)] + (wrap (list (` (ensure (object-fields! (list (~@ (List/map ast;text fields)))) + ($_ seq (~@ parsers))))))) + )) + +## [Polytypism] +(def: #hidden _map_ + (All [a b] (-> (-> a b) (List a) (List b))) + List/map) + +(poly: #export (|Codec@JSON//encode| *env* :x:) + (let [->Codec//encode (: (-> AST AST) + (lambda [.type.] (` (-> (~ .type.) JSON))))] + (let% [<basic> (do-template [<type> <matcher> <encoder>] + [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//encode (` <type>))) <encoder>))))] + + [Unit poly;unit (lambda [(~ (ast;symbol ["" "0"]))] #Null)] + [Bool poly;bool ;;boolean] + [Int poly;int (|>. int-to-real ;;number)] + [Real poly;real ;;number] + [Char poly;char (|>. char;->Text ;;string)] + [Text poly;text ;;string])] + ($_ compiler;either + <basic> + (with-gensyms [g!type-fun g!case g!input g!key g!val] + (do @ + [:sub: (poly;list :x:) + [g!vars members] (poly;tuple :sub:) + :val: (case members + (^ (list :key: :val:)) + (do @ [_ (poly;text :key:)] + (wrap :val:)) + + _ + (compiler;fail "")) + #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)] + .val. (|Codec@JSON//encode| new-*env* :val:) + #let [:x:+ (case g!vars + #;Nil + (->Codec//encode (type;type-to-ast :x:)) + + _ + (` (All (~ g!type-fun) [(~@ g!vars)] + (-> (~@ (List/map ->Codec//encode g!vars)) + (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]] + (wrap (` (: (~ :x:+) + (lambda [(~@ g!vars) (~ g!input)] + (|> (~ g!input) + (_map_ (: (-> [Text (~ (type;type-to-ast :val:))] + [Text JSON]) + (lambda [[(~ g!key) (~ g!val)]] + [(~ g!key) + ((~ .val.) (~ g!val))]))) + ;;object)) + ))) + )) + (do @ + [:sub: (poly;maybe :x:) + .sub. (|Codec@JSON//encode| *env* :sub:)] + (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:))) + (;;nullable (~ .sub.)))))) + (do @ + [:sub: (poly;list :x:) + .sub. (|Codec@JSON//encode| *env* :sub:)] + (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:))) + (|>. (_map_ (~ .sub.)) vector;list-to-vector ;;array))))) + (with-gensyms [g!type-fun g!case g!input] + (do @ + [[g!vars cases] (poly;variant :x:) + #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)] + pattern-matching (mapM @ + (lambda [[name :case:]] + (do @ + [#let [tag (ast;tag name)] + encoder (|Codec@JSON//encode| new-*env* :case:)] + (wrap (list (` ((~ tag) (~ g!case))) + (` (;;json [(~ (ast;text (product;right name))) + ((~ encoder) (~ g!case))])))))) + cases) + #let [:x:+ (case g!vars + #;Nil + (->Codec//encode (type;type-to-ast :x:)) + + _ + (` (All (~ g!type-fun) [(~@ g!vars)] + (-> (~@ (List/map ->Codec//encode g!vars)) + (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]] + (wrap (` (: (~ :x:+) + (lambda [(~@ g!vars) (~ g!input)] + (case (~ g!input) + (~@ (List/join pattern-matching)))) + ))))) + (with-gensyms [g!type-fun g!case g!input] + (do @ + [[g!vars slots] (poly;record :x:) + #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)] + synthesis (mapM @ + (lambda [[name :slot:]] + (do @ + [encoder (|Codec@JSON//encode| new-*env* :slot:)] + (wrap [(` (~ (ast;text (product;right name)))) + (` ((~ encoder) (get@ (~ (ast;tag name)) (~ g!input))))]))) + slots) + #let [:x:+ (case g!vars + #;Nil + (->Codec//encode (type;type-to-ast :x:)) + + _ + (` (All (~ g!type-fun) [(~@ g!vars)] + (-> (~@ (List/map ->Codec//encode g!vars)) + (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]] + (wrap (` (: (~ :x:+) + (lambda [(~@ g!vars) (~ g!input)] + (;;json (~ (ast;record synthesis)))) + ))))) + (with-gensyms [g!type-fun g!case g!input] + (do @ + [[g!vars members] (poly;tuple :x:) + #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)] + pattern-matching (mapM @ + (lambda [:member:] + (do @ + [g!member (compiler;gensym "g!member") + encoder (|Codec@JSON//encode| new-*env* :member:)] + (wrap [g!member encoder]))) + members) + #let [:x:+ (case g!vars + #;Nil + (->Codec//encode (type;type-to-ast :x:)) + + _ + (` (All (~ g!type-fun) [(~@ g!vars)] + (-> (~@ (List/map ->Codec//encode g!vars)) + (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))] + #let [.tuple. (` [(~@ (List/map product;left pattern-matching))])]] + (wrap (` (: (~ :x:+) + (lambda [(~@ g!vars) (~ g!input)] + (case (~ g!input) + (~ .tuple.) + (;;array (list (~@ (List/map (lambda [[g!member g!encoder]] + (` ((~ g!encoder) (~ g!member)))) + pattern-matching)))))) + ))) + )) + (do @ + [[:func: :args:] (poly;apply :x:) + .func. (|Codec@JSON//encode| *env* :func:) + .args. (mapM @ (|Codec@JSON//encode| *env*) :args:)] + (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:))) + ((~ .func.) (~@ .args.)))))) + (poly;bound *env* :x:) + (compiler;fail (format "Can't create JSON encoder for: " (type;type-to-text :x:))) + )))) + +(poly: #export (Codec<JSON,?>//decode *env* :x:) + (let [->Codec//decode (: (-> AST AST) + (lambda [.type.] (` (-> JSON (Error (~ .type.))))))] + (let% [<basic> (do-template [<type> <matcher> <decoder>] + [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//decode (` <type>))) <decoder>))))] + + [Unit poly;unit ;;null] + [Bool poly;bool ;;bool] + [Int poly;int ;;int] + [Real poly;real ;;real] + [Char poly;char ;;char] + [Text poly;text ;;text]) + <complex> (do-template [<type> <matcher> <decoder>] + [(do @ + [:sub: (<matcher> :x:) + .sub. (Codec<JSON,?>//decode *env* :sub:)] + (wrap (` (: (~ (->Codec//decode (type;type-to-ast :x:))) + (<decoder> (~ .sub.))))))] + + [Maybe poly;maybe ;;nullable] + [List poly;list ;;array])] + ($_ compiler;either + <basic> + (with-gensyms [g!type-fun g!case g!input g!key g!val] + (do @ + [:sub: (poly;list :x:) + [g!vars members] (poly;tuple :sub:) + :val: (case members + (^ (list :key: :val:)) + (do @ [_ (poly;text :key:)] + (wrap :val:)) + + _ + (compiler;fail "")) + #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)] + .val. (Codec<JSON,?>//decode new-*env* :val:) + #let [:x:+ (case g!vars + #;Nil + (->Codec//decode (type;type-to-ast :x:)) + + _ + (` (All (~ g!type-fun) [(~@ g!vars)] + (-> (~@ (List/map ->Codec//decode g!vars)) + (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]] + (wrap (` (: (~ :x:+) + (lambda [(~@ g!vars) (~ g!input)] + (do Monad<Error> + [(~ g!key) (;;keys (~ g!input))] + (mapM (~ (' %)) + (lambda [(~ g!key)] + (do Monad<Error> + [(~ g!val) (;;get (~ g!key) (~ g!input)) + (~ g!val) (;;run (~ .val.) (~ g!val))] + ((~ (' wrap)) [(~ g!key) (~ g!val)]))) + (~ g!key)))) + ))) + )) + <complex> + (with-gensyms [g!type-fun g!_] + (do @ + [[g!vars cases] (poly;variant :x:) + #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)] + pattern-matching (mapM @ + (lambda [[name :case:]] + (do @ + [#let [tag (ast;tag name)] + decoder (Codec<JSON,?>//decode new-*env* :case:)] + (wrap (list (` (do Monad<Parser> + [(~ g!_) (;;at 0 (;;text! (~ (ast;text (product;right name))))) + (~ g!_) (;;at 1 (~ decoder))] + ((~ (' wrap)) ((~ tag) (~ g!_))))))))) + cases) + #let [:x:+ (case g!vars + #;Nil + (->Codec//decode (type;type-to-ast :x:)) + + _ + (` (All (~ g!type-fun) [(~@ g!vars)] + (-> (~@ (List/map ->Codec//decode g!vars)) + (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars))))))))) + base-parser (` ($_ ;;either + (~@ (List/join pattern-matching)))) + parser (case g!vars + #;Nil + base-parser + + _ + (` (lambda [(~@ g!vars)] (~ base-parser))))]] + (wrap (` (: (~ :x:+) (~ parser)))) + )) + (with-gensyms [g!type-fun g!case g!input] + (do @ + [[g!vars slots] (poly;record :x:) + #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)] + extraction (mapM @ + (lambda [[name :slot:]] + (do @ + [#let [g!member (ast;symbol ["" (product;right name)])] + decoder (Codec<JSON,?>//decode new-*env* :slot:)] + (wrap (list g!member + (` (;;get (~ (ast;text (product;right name))) (~ g!input))) + g!member + (` ((~ decoder) (~ g!member))))))) + slots) + #let [:x:+ (case g!vars + #;Nil + (->Codec//decode (type;type-to-ast :x:)) + + _ + (` (All (~ g!type-fun) [(~@ g!vars)] + (-> (~@ (List/map ->Codec//decode g!vars)) + (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]] + (wrap (` (: (~ :x:+) + (lambda [(~@ g!vars) (~ g!input)] + (do Monad<Error> + [(~@ (List/join extraction))] + ((~ (' wrap)) (~ (ast;record (List/map (lambda [[name :slot:]] + [(ast;tag name) (ast;symbol ["" (product;right name)])]) + slots)))))) + ))))) + (with-gensyms [g!type-fun g!case g!input] + (do @ + [[g!vars members] (poly;tuple :x:) + #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)] + pattern-matching (mapM @ + (lambda [:member:] + (do @ + [g!member (compiler;gensym "g!member") + decoder (Codec<JSON,?>//decode new-*env* :member:)] + (wrap [g!member decoder]))) + members) + #let [:x:+ (case g!vars + #;Nil + (->Codec//decode (type;type-to-ast :x:)) + + _ + (` (All (~ g!type-fun) [(~@ g!vars)] + (-> (~@ (List/map ->Codec//decode g!vars)) + (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))] + #let [.decoder. (case g!vars + #;Nil + (` (;;shape^ [(~@ (List/map product;right pattern-matching))])) + + _ + (` (lambda [(~@ g!vars)] + (;;shape^ [(~@ (List/map product;right pattern-matching))]))))]] + (wrap (` (: (~ :x:+) (~ .decoder.)))) + )) + (do @ + [[:func: :args:] (poly;apply :x:) + .func. (Codec<JSON,?>//decode *env* :func:) + .args. (mapM @ (Codec<JSON,?>//decode *env*) :args:)] + (wrap (` (: (~ (->Codec//decode (type;type-to-ast :x:))) + ((~ .func.) (~@ .args.)))))) + (do @ + [g!bound (poly;bound *env* :x:)] + (wrap g!bound)) + (compiler;fail (format "Can't create JSON decoder for: " (type;type-to-text :x:))) + )))) + +(syntax: #export (Codec<JSON,?> :x:) + (wrap (list (` (: (Codec JSON (~ :x:)) + (struct + (def: (~ (' encode)) (|Codec@JSON//encode| (~ :x:))) + (def: (~ (' decode)) (Codec<JSON,?>//decode (~ :x:))) + )))))) diff --git a/stdlib/source/lux/data/ident.lux b/stdlib/source/lux/data/ident.lux new file mode 100644 index 000000000..4f85da77d --- /dev/null +++ b/stdlib/source/lux/data/ident.lux @@ -0,0 +1,57 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control eq + codec + hash) + (data [text "Text/" Monoid<Text> Eq<Text>]))) + +## [Types] +## (type: Ident +## [Text Text]) + +## [Functions] +(do-template [<name> <side>] + [(def: #export (<name> [module name]) + (-> Ident Text) + <side>)] + + [module module] + [name name] + ) + +## [Structures] +(struct: #export _ (Eq Ident) + (def: (= [xmodule xname] [ymodule yname]) + (and (Text/= xmodule ymodule) + (Text/= xname yname)))) + +(struct: #export _ (Codec Text Ident) + (def: (encode [module name]) + (case module + "" name + _ ($_ Text/append module ";" name))) + + (def: (decode input) + (if (Text/= "" input) + (#;Left (Text/append "Invalid format for Ident: " input)) + (case (text;split-all-with ";" input) + (^ (list name)) + (#;Right ["" name]) + + (^ (list module name)) + (#;Right [module name]) + + _ + (#;Left (Text/append "Invalid format for Ident: " input)))))) + +(struct: #export _ (Hash Ident) + (def: eq Eq<Ident>) + + (def: (hash [module name]) + (let [(^open) text;Hash<Text>] + (*+ (hash module) (hash name))))) diff --git a/stdlib/source/lux/data/identity.lux b/stdlib/source/lux/data/identity.lux new file mode 100644 index 000000000..c986db0c0 --- /dev/null +++ b/stdlib/source/lux/data/identity.lux @@ -0,0 +1,37 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux/control (functor #as F #refer #all) + (applicative #as A #refer #all) + (monad #as M #refer #all) + (comonad #as CM #refer #all))) + +## [Types] +(type: #export (Identity a) + a) + +## [Structures] +(struct: #export _ (Functor Identity) + (def: map id)) + +(struct: #export _ (Applicative Identity) + (def: functor Functor<Identity>) + + (def: wrap id) + + (def: (apply ff fa) + (ff fa))) + +(struct: #export _ (Monad Identity) + (def: applicative Applicative<Identity>) + + (def: join id)) + +(struct: #export _ (CoMonad Identity) + (def: functor Functor<Identity>) + (def: unwrap id) + (def: split id)) diff --git a/stdlib/source/lux/data/log.lux b/stdlib/source/lux/data/log.lux new file mode 100644 index 000000000..9e6be6d56 --- /dev/null +++ b/stdlib/source/lux/data/log.lux @@ -0,0 +1,62 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux/control monoid + ["A" applicative #*] + functor + ["M" monad #*])) + +(type: #export (Log l a) + [l a]) + +(struct: #export Functor<Log> (All [l] + (Functor (Log l))) + (def: (map f fa) + (let [[log datum] fa] + [log (f datum)]))) + +(struct: #export (Applicative<Log> mon) (All [l] + (-> (Monoid l) (Applicative (Log l)))) + (def: functor Functor<Log>) + + (def: (wrap x) + [(:: mon unit) x]) + + (def: (apply ff fa) + (let [[log1 f] ff + [log2 a] fa] + [(:: mon append log1 log2) (f a)]))) + +(struct: #export (Monad<Log> mon) (All [l] + (-> (Monoid l) (Monad (Log l)))) + (def: applicative (Applicative<Log> mon)) + + (def: (join mma) + (let [[log1 [log2 a]] mma] + [(:: mon append log1 log2) a]))) + +(def: #export (log l) + (All [l] (-> l (Log l Unit))) + [l []]) + +(struct: #export (LogT Monoid<l> Monad<M>) + (All [l M] (-> (Monoid l) (Monad M) (Monad (All [a] (M (Log l a)))))) + (def: applicative (A;compA (get@ #M;applicative Monad<M>) (Applicative<Log> Monoid<l>))) + (def: (join MlMla) + (do Monad<M> + [[l1 Mla] (: (($ 1) (Log ($ 0) (($ 1) (Log ($ 0) ($ 2))))) + MlMla) + [l2 a] (: (($ 1) (Log ($ 0) ($ 2))) + Mla)] + (wrap [(:: Monoid<l> append l1 l2) a])))) + +(def: #export (lift-log Monoid<l> Monad<M>) + (All [l M a] (-> (Monoid l) (Monad M) (-> (M a) (M (Log l a))))) + (lambda [ma] + (do Monad<M> + [a ma] + (wrap [(:: Monoid<l> unit) a])))) diff --git a/stdlib/source/lux/data/maybe.lux b/stdlib/source/lux/data/maybe.lux new file mode 100644 index 000000000..16aa9e30a --- /dev/null +++ b/stdlib/source/lux/data/maybe.lux @@ -0,0 +1,82 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control (monoid #as m #refer #all) + (functor #as F #refer #all) + (applicative #as A #refer #all) + (monad #as M #refer #all) + eq))) + +## [Types] +## (type: (Maybe a) +## #;None +## (#;Some a)) + +## [Structures] +(struct: #export Monoid<Maybe> (All [a] (Monoid (Maybe a))) + (def: unit #;None) + (def: (append xs ys) + (case xs + #;None ys + (#;Some x) (#;Some x)))) + +(struct: #export _ (Functor Maybe) + (def: (map f ma) + (case ma + #;None #;None + (#;Some a) (#;Some (f a))))) + +(struct: #export _ (Applicative Maybe) + (def: functor Functor<Maybe>) + + (def: (wrap x) + (#;Some x)) + + (def: (apply ff fa) + (case [ff fa] + [(#;Some f) (#;Some a)] + (#;Some (f a)) + + _ + #;None))) + +(struct: #export _ (Monad Maybe) + (def: applicative Applicative<Maybe>) + + (def: (join mma) + (case mma + #;None #;None + (#;Some xs) xs))) + +(struct: #export (Eq<Maybe> Eq<a>) (All [a] (-> (Eq a) (Eq (Maybe a)))) + (def: (= mx my) + (case [mx my] + [#;None #;None] + true + + [(#;Some x) (#;Some y)] + (:: Eq<a> = x y) + + _ + false))) + +(struct: #export (MaybeT Monad<M>) + (All [M] (-> (Monad M) (Monad (All [a] (M (Maybe a)))))) + (def: applicative (A;compA (get@ #M;applicative Monad<M>) Applicative<Maybe>)) + (def: (join MmMma) + (do Monad<M> + [mMma MmMma] + (case mMma + #;None + (wrap #;None) + + (#;Some Mma) + (join Mma))))) + +(def: #export (lift-maybe Monad<M>) + (All [M a] (-> (Monad M) (-> (M a) (M (Maybe a))))) + (liftM Monad<M> (:: Monad<Maybe> wrap))) diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux new file mode 100644 index 000000000..41c75402e --- /dev/null +++ b/stdlib/source/lux/data/number.lux @@ -0,0 +1,222 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control number + monoid + eq + hash + [ord] + enum + bounded + codec) + (data error))) + +## [Structures] +(do-template [<type> <test>] + [(struct: #export _ (Eq <type>) + (def: = <test>))] + + [ Nat =+] + [ Int =] + [Frac =..] + [Real =.] + ) + +(do-template [<type> <eq> <lt> <lte> <gt> <gte>] + [(struct: #export _ (ord;Ord <type>) + (def: eq <eq>) + (def: < <lt>) + (def: <= <lte>) + (def: > <gt>) + (def: >= <gte>))] + + [ Nat Eq<Nat> <+ <=+ >+ >=+] + [ Int Eq<Int> < <= > >=] + [Frac Eq<Frac> <.. <=.. >.. >=..] + [Real Eq<Real> <. <=. >. >=.] + ) + +(struct: #export _ (Number Nat) + (def: ord Ord<Nat>) + (def: + ++) + (def: - -+) + (def: * *+) + (def: / /+) + (def: % %+) + (def: negate id) + (def: abs id) + (def: (signum x) + (case x + +0 +0 + _ +1)) + ) + +(do-template [<type> <ord> <+> <-> <*> </> <%> <=> <<> <0> <1> <-1>] + [(struct: #export _ (Number <type>) + (def: ord <ord>) + (def: + <+>) + (def: - <->) + (def: * <*>) + (def: / </>) + (def: % <%>) + (def: negate (<*> <-1>)) + (def: (abs x) + (if (<<> <0> x) + (<*> <-1> x) + x)) + (def: (signum x) + (cond (<=> <0> x) <0> + (<<> <0> x) <-1> + ## else + <1>)) + )] + + [ Int Ord<Int> + - * / % = < 0 1 -1] + [Real Ord<Real> +. -. *. /. %. =. <. 0.0 1.0 -1.0] + ) + +(do-template [<type> <ord> <succ> <pred>] + [(struct: #export _ (Enum <type>) + (def: ord <ord>) + (def: succ <succ>) + (def: pred <pred>))] + + [Nat Ord<Nat> (++ +1) (-+ +1)] + [Int Ord<Int> inc dec] + ) + +(do-template [<type> <top> <bottom>] + [(struct: #export _ (Bounded <type>) + (def: top <top>) + (def: bottom <bottom>))] + + [ Nat (_lux_proc ["nat" "max-value"] []) (_lux_proc ["nat" "min-value"] [])] + [ Int (_lux_proc ["jvm" "getstatic:java.lang.Long:MAX_VALUE"] []) (_lux_proc ["jvm" "getstatic:java.lang.Long:MIN_VALUE"] [])] + [Real (_lux_proc ["jvm" "getstatic:java.lang.Double:MAX_VALUE"] []) (_lux_proc ["jvm" "getstatic:java.lang.Double:MIN_VALUE"] [])]) + +(do-template [<name> <type> <unit> <append>] + [(struct: #export <name> (Monoid <type>) + (def: unit <unit>) + (def: (append x y) (<append> x y)))] + + [ Add@Monoid<Nat> Nat +0 ++] + [ Mul@Monoid<Nat> Nat +1 *+] + [ Max@Monoid<Nat> Nat (:: Bounded<Nat> bottom) max+] + [ Min@Monoid<Nat> Nat (:: Bounded<Nat> top) min+] + [ Add@Monoid<Int> Int 0 +] + [ Mul@Monoid<Int> Int 1 *] + [ Max@Monoid<Int> Int (:: Bounded<Int> bottom) max] + [ Min@Monoid<Int> Int (:: Bounded<Int> top) min] + [Add@Monoid<Real> Real 0.0 +.] + [Mul@Monoid<Real> Real 1.0 *.] + [Max@Monoid<Real> Real (:: Bounded<Real> bottom) max.] + [Min@Monoid<Real> Real (:: Bounded<Real> top) min.] + ) + +(def: (text.replace pattern value template) + (-> Text Text Text Text) + (_lux_proc ["jvm" "invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"] [template pattern value])) + +(do-template [<type> <encoder> <decoder> <error>] + [(struct: #export _ (Codec Text <type>) + (def: (encode x) + (_lux_proc <encoder> [x])) + + (def: (decode input) + (case (_lux_proc <decoder> [input]) + (#;Some value) + (#;Right value) + + #;None + (#;Left <error>))))] + + [Nat ["nat" "encode"] ["nat" "decode"] "Couldn't decode Nat"] + [Frac ["frac" "encode"] ["frac" "decode"] "Couldn't decode Frac"] + ) + +(def: clean-number + (-> Text Text) + (|>. (text.replace "," "") + (text.replace "_" ""))) + +(do-template [<type> <encode> <decode> <error>] + [(struct: #export _ (Codec Text <type>) + (def: (encode x) + (_lux_proc ["jvm" <encode>] [x])) + + (def: (decode input) + (_lux_proc ["jvm" "try"] + [(#;Right (_lux_proc ["jvm" <decode>] [(clean-number input)])) + (lambda [e] (#;Left <error>))])))] + + [ Int "invokevirtual:java.lang.Object:toString:" "invokestatic:java.lang.Long:parseLong:java.lang.String" "Couldn't parse Int"] + [Real "invokevirtual:java.lang.Object:toString:" "invokestatic:java.lang.Double:parseDouble:java.lang.String" "Couldn't parse Real"] + ) + +(struct: #export _ (Hash Nat) + (def: eq Eq<Nat>) + (def: hash id)) + +(struct: #export _ (Hash Int) + (def: eq Eq<Int>) + (def: hash int-to-nat)) + +(struct: #export _ (Hash Real) + (def: eq Eq<Real>) + + (def: hash + (|>. (:: Codec<Text,Real> encode) + [] + (_lux_proc ["jvm" "invokevirtual:java.lang.Object:hashCode:"]) + [] + (_lux_proc ["jvm" "i2l"]) + int-to-nat))) + +## [Values & Syntax] +(do-template [<struct> <to-proc> <radix> <macro> <error> <doc>] + [(struct: #export <struct> (Codec Text Nat) + (def: (encode value) + (_lux_proc ["jvm" <to-proc>] [(nat-to-int value)])) + + (def: (decode repr) + (_lux_proc ["jvm" "try"] + [(#;Right (int-to-nat (_lux_proc ["jvm" "invokestatic:java.lang.Long:valueOf:java.lang.String,int"] [repr (_lux_proc ["jvm" "l2i"] [<radix>])]))) + (lambda [ex] (#;Left <error>))]))) + + (macro: #export (<macro> tokens state) + {#;doc <doc>} + (case tokens + (#;Cons [meta (#;TextS repr)] #;Nil) + (case (:: <struct> decode repr) + (#;Right value) + (#;Right [state (list [meta (#;NatS value)])]) + + (#;Left error) + (#;Left error)) + + _ + (#;Left <error>)))] + + [Binary@Codec<Text,Nat> "invokestatic:java.lang.Long:toBinaryString:long" 2 bin "Invalid binary syntax." + (doc "Given syntax for a binary number, generates a Nat." + (bin "11001001"))] + [Octal@Codec<Text,Nat> "invokestatic:java.lang.Long:toOctalString:long" 8 oct "Invalid octal syntax." + (doc "Given syntax for an octal number, generates a Nat." + (oct "0615243"))] + [Hex@Codec<Text,Nat> "invokestatic:java.lang.Long:toHexString:long" 16 hex "Invalid hexadecimal syntax." + (doc "Given syntax for a hexadecimal number, generates a Nat." + (hex "deadBEEF"))] + ) + +(do-template [<name> <field>] + [(def: #export <name> Real + (_lux_proc ["jvm" <field>] []))] + + [nan "getstatic:java.lang.Double:NaN"] + [+inf "getstatic:java.lang.Double:POSITIVE_INFINITY"] + [-inf "getstatic:java.lang.Double:NEGATIVE_INFINITY"] + ) diff --git a/stdlib/source/lux/data/product.lux b/stdlib/source/lux/data/product.lux new file mode 100644 index 000000000..f542d7a38 --- /dev/null +++ b/stdlib/source/lux/data/product.lux @@ -0,0 +1,35 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: lux) + +## [Functions] +(do-template [<name> <type> <output>] + [(def: #export (<name> xy) + (All [a b] (-> [a b] <type>)) + (let [[x y] xy] + <output>))] + + [left a x] + [right b y]) + +(def: #export (curry f) + (All [a b c] + (-> (-> [a b] c) + (-> a b c))) + (lambda [x y] + (f [x y]))) + +(def: #export (uncurry f) + (All [a b c] + (-> (-> a b c) (-> [a b] c))) + (lambda [xy] + (let [[x y] xy] + (f x y)))) + +(def: #export (swap xy) + (All [a b] (-> [a b] [b a])) + (let [[x y] xy] + [y x])) diff --git a/stdlib/source/lux/data/struct/array.lux b/stdlib/source/lux/data/struct/array.lux new file mode 100644 index 000000000..6c81683d3 --- /dev/null +++ b/stdlib/source/lux/data/struct/array.lux @@ -0,0 +1,224 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monoid + functor + applicative + monad + eq + fold) + (data error + (struct [list "List/" Fold<List>]) + [product]) + )) + +## [Types] +(type: #export (Array a) + (#;HostT "#Array" (#;Cons a #;Nil))) + +## [Functions] +(def: #export (new size) + (All [a] (-> Nat (Array a))) + (_lux_proc ["array" "new"] [size])) + +(def: #export (size xs) + (All [a] (-> (Array a) Nat)) + (_lux_proc ["array" "size"] [xs])) + +(def: #export (get i xs) + (All [a] + (-> Nat (Array a) (Maybe a))) + (_lux_proc ["array" "get"] [xs i])) + +(def: #export (put i x xs) + (All [a] + (-> Nat a (Array a) (Array a))) + (_lux_proc ["array" "put"] [xs i x])) + +(def: #export (remove i xs) + (All [a] + (-> Nat (Array a) (Array a))) + (_lux_proc ["array" "remove"] [xs i])) + +(def: #export (copy length src-start src-array dest-start dest-array) + (All [a] (-> Nat Nat (Array a) Nat (Array a) + (Array a))) + (if (=+ +0 length) + dest-array + (List/fold (lambda [offset target] + (case (get (++ offset src-start) src-array) + #;None + target + + (#;Some value) + (put (++ offset dest-start) value target))) + dest-array + (list;range+ +0 (dec+ length))))) + +(def: #export (occupied array) + {#;doc "Finds out how many cells in an array are occupied."} + (All [a] (-> (Array a) Nat)) + (List/fold (lambda [idx count] + (case (get idx array) + #;None + count + + (#;Some _) + (inc+ count))) + +0 + (list;indices (size array)))) + +(def: #export (vacant array) + {#;doc "Finds out how many cells in an array are vacant."} + (All [a] (-> (Array a) Nat)) + (-+ (occupied array) (size array))) + +(def: #export (filter p xs) + (All [a] + (-> (-> a Bool) (Array a) (Array a))) + (List/fold (: (-> Nat (Array ($ 0)) (Array ($ 0))) + (lambda [idx xs'] + (case (get idx xs) + #;None + xs' + + (#;Some x) + (if (p x) + xs' + (remove idx xs'))))) + xs + (list;indices (size xs)))) + +(def: #export (find p xs) + (All [a] + (-> (-> a Bool) (Array a) (Maybe a))) + (let [arr-size (size xs)] + (loop [idx +0] + (if (<+ arr-size idx) + (case (get idx xs) + #;None + (recur (inc+ idx)) + + (#;Some x) + (if (p x) + (#;Some x) + (recur (inc+ idx)))) + #;None)))) + +(def: #export (find+ p xs) + {#;doc "Just like 'find', but with access to the index of each value."} + (All [a] + (-> (-> Nat a Bool) (Array a) (Maybe [Nat a]))) + (let [arr-size (size xs)] + (loop [idx +0] + (if (<+ arr-size idx) + (case (get idx xs) + #;None + (recur (inc+ idx)) + + (#;Some x) + (if (p idx x) + (#;Some [idx x]) + (recur (inc+ idx)))) + #;None)))) + +(def: #export (clone xs) + (All [a] (-> (Array a) (Array a))) + (let [arr-size (size xs)] + (List/fold (lambda [idx ys] + (case (get idx xs) + #;None + ys + + (#;Some x) + (put idx x ys))) + (new arr-size) + (list;indices arr-size)))) + +(def: #export (from-list xs) + (All [a] (-> (List a) (Array a))) + (product;right (List/fold (lambda [x [idx arr]] + [(inc+ idx) (put idx x arr)]) + [+0 (new (list;size xs))] + xs))) + +(def: #export (to-list array) + (All [a] (-> (Array a) (List a))) + (let [_size (size array)] + (product;right (List/fold (lambda [_ [idx tail]] + (case (get idx array) + (#;Some head) + [(dec+ idx) (#;Cons head tail)] + + #;None + [(dec+ idx) tail])) + [(dec+ _size) #;Nil] + (list;repeat _size []) + )))) + +## [Structures] +(struct: #export (Eq<Array> (^open "a:")) + (All [a] (-> (Eq a) (Eq (Array a)))) + (def: (= xs ys) + (let [sxs (size xs) + sxy (size ys)] + (and (lux;=+ sxy sxs) + (List/fold (lambda [idx prev] + (and prev + (case [(get idx xs) (get idx ys)] + [#;None #;None] + true + + [(#;Some x) (#;Some y)] + (a:= x y) + + _ + false))) + true + (list;range+ +0 (dec+ sxs))))) + )) + +(struct: #export Monoid<Array> (All [a] + (Monoid (Array a))) + (def: unit (new +0)) + + (def: (append xs ys) + (let [sxs (size xs) + sxy (size ys)] + (|> (new (++ sxy sxs)) + (copy sxs +0 xs +0) + (copy sxy +0 ys sxs))))) + +(struct: #export _ (Functor Array) + (def: (map f ma) + (let [arr-size (size ma)] + (if (=+ +0 arr-size) + (new arr-size) + (List/fold (: (-> Nat (Array ($ 1)) (Array ($ 1))) + (lambda [idx mb] + (case (get idx ma) + #;None + mb + + (#;Some x) + (put idx (f x) mb)))) + (new arr-size) + (list;range+ +0 (dec+ arr-size))))))) + +(struct: #export _ (Fold Array) + (def: (fold f init xs) + (let [arr-size (size xs)] + (loop [so-far init + idx +0] + (if (<+ arr-size idx) + (case (get idx xs) + #;None + (recur so-far (inc+ idx)) + + (#;Some value) + (recur (f value so-far) (inc+ idx))) + so-far))))) diff --git a/stdlib/source/lux/data/struct/dict.lux b/stdlib/source/lux/data/struct/dict.lux new file mode 100644 index 000000000..a10e30dca --- /dev/null +++ b/stdlib/source/lux/data/struct/dict.lux @@ -0,0 +1,675 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control hash + eq) + (data maybe + (struct [list "List/" Fold<List> Functor<List> Monoid<List>] + [array #+ Array "Array/" Functor<Array> Fold<Array>]) + [bit] + [product] + text/format + [number]) + )) + +## This implementation of Hash Array Mapped Trie (HAMT) is based on +## Clojure's PersistentHashMap implementation. +## That one is further based on Phil Bagwell's Hash Array Mapped Trie. + +## [Utils] +## Bitmaps are used to figure out which branches on a #Base node are +## populated. The number of bits that are 1s in a bitmap signal the +## size of the #Base node. +(type: BitMap Nat) + +## Represents the position of a node in a BitMap. +## It's meant to be a single bit set on a 32-bit word. +## The position of the bit reflects whether an entry in an analogous +## position exists within a #Base, as reflected in it's BitMap. +(type: BitPosition Nat) + +## An index into an array. +(type: Index Nat) + +## A hash-code derived from a key during tree-traversal. +(type: Hash-Code Nat) + +## Represents the nesting level of a leaf or node, when looking-it-up +## while exploring the tree. +## Changes in levels are done by right-shifting the hashes of keys by +## the appropriate multiple of the branching-exponent. +## A shift of 0 means root level. +## A shift of (* branching-exponent 1) means level 2. +## A shift of (* branching-exponent N) means level N+1. +(type: Level Nat) + +## Nodes for the tree data-structure that organizes the data inside +## Dicts. +(type: (Node k v) + (#Hierarchy Nat (Array (Node k v))) + (#Base BitMap + (Array (Either (Node k v) + [k v]))) + (#Collisions Hash-Code (Array [k v]))) + +## #Hierarchy nodes are meant to point down only to lower-level nodes. +(type: (Hierarchy k v) + [Nat (Array (Node k v))]) + +## #Base nodes may point down to other nodes, but also to leaves, +## which are KV pairs. +(type: (Base k v) + (Array (Either (Node k v) + [k v]))) + +## #Collisions are collections of KV-pairs for which the key is +## different on each case, but their hashes are all the same (thus +## causing a collision). +(type: (Collisions k v) + (Array [k v])) + +## That bitmap for an empty #Base is 0. +## Which is the same as 0000 0000 0000 0000 0000 0000 0000 0000. +## Or 0x00000000. +## Which is 32 zeroes, since the branching factor is 32. +(def: clean-bitmap + BitMap + +0) + +## Bitmap position (while looking inside #Base nodes) is determined by +## getting 5 bits from a hash of the key being looked up and using +## them as an index into the array inside #Base. +## Since the data-structure can have multiple levels (and the hash has +## more than 5 bits), the binary-representation of the hash is shifted +## by 5 positions on each step (2^5 = 32, which is the branching +## factor). +## The initial shifting level, though, is 0 (which corresponds to the +## shift in the shallowest node on the tree, which is the root node). +(def: root-level + Level + +0) + +## The exponent to which 2 must be elevated, to reach the branching +## factor of the data-structure. +(def: branching-exponent + Nat + +5) + +## The threshold on which #Hierarchy nodes are demoted to #Base nodes, +## which is 1/4 of the branching factor (or a left-shift 2). +(def: demotion-threshold + Nat + (bit;<< (-+ +2 branching-exponent) +1)) + +## The threshold on which #Base nodes are promoted to #Hierarchy nodes, +## which is 1/2 of the branching factor (or a left-shift 1). +(def: promotion-threshold + Nat + (bit;<< (-+ +1 branching-exponent) +1)) + +## The size of hierarchy-nodes, which is 2^(branching-exponent). +(def: hierarchy-nodes-size + Nat + (bit;<< branching-exponent +1)) + +## The cannonical empty node, which is just an empty #Base node. +(def: empty + Node + (#Base clean-bitmap (array;new +0))) + +## Expands a copy of the array, to have 1 extra slot, which is used +## for storing the value. +(def: (insert! idx value old-array) + (All [a] (-> Index a (Array a) (Array a))) + (let [old-size (array;size old-array)] + (|> (: (Array ($ 0)) + (array;new (inc+ old-size))) + (array;copy idx +0 old-array +0) + (array;put idx value) + (array;copy (-+ idx old-size) idx old-array (inc+ idx))))) + +## Creates a copy of an array with an index set to a particular value. +(def: (update! idx value array) + (All [a] (-> Index a (Array a) (Array a))) + (|> array array;clone (array;put idx value))) + +## Creates a clone of the array, with an empty position at index. +(def: (vacant! idx array) + (All [a] (-> Index (Array a) (Array a))) + (|> array array;clone (array;remove idx))) + +## Shrinks a copy of the array by removing the space at index. +(def: (remove! idx array) + (All [a] (-> Index (Array a) (Array a))) + (let [new-size (dec+ (array;size array))] + (|> (array;new new-size) + (array;copy idx +0 array +0) + (array;copy (-+ idx new-size) (inc+ idx) array idx)))) + +## Given a top-limit for indices, produces all indices in [0, R). +(def: indices-for + (-> Nat (List Index)) + (|>. dec+ (list;range+ +0))) + +## Increases the level-shift by the branching-exponent, to explore +## levels further down the tree. +(def: level-up + (-> Level Level) + (++ branching-exponent)) + +(def: hierarchy-mask BitMap (dec+ hierarchy-nodes-size)) + +## Gets the branching-factor sized section of the hash corresponding +## to a particular level, and uses that as an index into the array. +(def: (level-index level hash) + (-> Level Hash-Code Index) + (bit;& hierarchy-mask + (bit;>>> level hash))) + +## A mechanism to go from indices to bit-positions. +(def: (->bit-position index) + (-> Index BitPosition) + (bit;<< index +1)) + +## The bit-position within a base that a given hash-code would have. +(def: (bit-position level hash) + (-> Level Hash-Code BitPosition) + (->bit-position (level-index level hash))) + +(def: (bit-position-is-set? bit bitmap) + (-> BitPosition BitMap Bool) + (not (=+ clean-bitmap (bit;& bit bitmap)))) + +## Figures out whether a bitmap only contains a single bit-position. +(def: only-bit-position? + (-> BitPosition BitMap Bool) + =+) + +(def: (set-bit-position bit bitmap) + (-> BitPosition BitMap BitMap) + (bit;| bit bitmap)) + +(def: unset-bit-position + (-> BitPosition BitMap BitMap) + bit;^) + +## Figures out the size of a bitmap-indexed array by counting all the +## 1s within the bitmap. +(def: bitmap-size + (-> BitMap Nat) + bit;count) + +## A mask that, for a given bit position, only allows all the 1s prior +## to it, which would indicate the bitmap-size (and, thus, index) +## associated with it. +(def: bit-position-mask + (-> BitPosition BitMap) + dec+) + +## The index on the base array, based on it's bit-position. +(def: (base-index bit-position bitmap) + (-> BitPosition BitMap Index) + (bitmap-size (bit;& (bit-position-mask bit-position) + bitmap))) + +## Produces the index of a KV-pair within a #Collisions node. +(def: (collision-index Hash<K> key colls) + (All [K V] (-> (Hash K) K (Collisions K V) (Maybe Index))) + (:: Monad<Maybe> map product;left + (array;find+ (lambda [idx [key' val']] + (:: Hash<K> = key key')) + colls))) + +## When #Hierarchy nodes grow too small, they're demoted to #Base +## nodes to save space. +(def: (demote-hierarchy except-idx [h-size h-array]) + (All [k v] (-> Index (Hierarchy k v) [BitMap (Base k v)])) + (List/fold (lambda [idx (^@ node [bitmap base])] + (case (array;get idx h-array) + #;None node + (#;Some sub-node) (if (=+ except-idx idx) + node + [(set-bit-position (->bit-position idx) bitmap) + (array;put idx (#;Left sub-node) base)]) + )) + [clean-bitmap + (: (Base ($ 0) ($ 1)) + (array;new (dec+ h-size)))] + (list;indices (array;size h-array)))) + +## When #Base nodes grow too large, they're promoted to #Hierarchy to +## add some depth to the tree and help keep it's balance. +(def: (promote-base put' Hash<K> level bitmap base) + (All [K V] + (-> (-> Level Hash-Code K V (Hash K) (Node K V) (Node K V)) + (Hash K) Level + BitMap (Base K V) + (Array (Node K V)))) + (product;right (List/fold (lambda [hierarchy-idx (^@ default [base-idx h-array])] + (if (bit-position-is-set? (->bit-position hierarchy-idx) + bitmap) + [(inc+ base-idx) + (case (array;get base-idx base) + (#;Some (#;Left sub-node)) + (array;put hierarchy-idx sub-node h-array) + + (#;Some (#;Right [key' val'])) + (array;put hierarchy-idx + (put' (level-up level) (:: Hash<K> hash key') key' val' Hash<K> empty) + h-array) + + #;None + (undefined))] + default)) + [+0 + (: (Array (Node ($ 0) ($ 1))) + (array;new hierarchy-nodes-size))] + (indices-for hierarchy-nodes-size)))) + +## All empty nodes look the same (a #Base node with clean bitmap is +## used). +## So, this test is introduced to detect them. +(def: (empty?' node) + (All [K V] (-> (Node K V) Bool)) + (case node + (^~ (#Base ;;clean-bitmap _)) + true + + _ + false)) + +(def: (put' level hash key val Hash<K> node) + (All [K V] (-> Level Hash-Code K V (Hash K) (Node K V) (Node K V))) + (case node + ## For #Hierarchy nodes, I check whether I can add the element to + ## a sub-node. If impossible, I introduced a new singleton sub-node. + (#Hierarchy _size hierarchy) + (let [idx (level-index level hash) + [_size' sub-node] (: [Nat (Node ($ 0) ($ 1))] + (case (array;get idx hierarchy) + (#;Some sub-node) + [_size sub-node] + + _ + [(inc+ _size) empty]))] + (#Hierarchy _size' + (update! idx (put' (level-up level) hash key val Hash<K> sub-node) + hierarchy))) + + ## For #Base nodes, I check if the corresponding BitPosition has + ## already been used. + (#Base bitmap base) + (let [bit (bit-position level hash)] + (if (bit-position-is-set? bit bitmap) + ## If so... + (let [idx (base-index bit bitmap)] + (case (array;get idx base) + #;None + (undefined) + + ## If it's being used by a node, I add the KV to it. + (#;Some (#;Left sub-node)) + (let [sub-node' (put' (level-up level) hash key val Hash<K> sub-node)] + (#Base bitmap (update! idx (#;Left sub-node') base))) + + ## Otherwise, if it's being used by a KV, I compare the keys. + (#;Some (#;Right key' val')) + (if (:: Hash<K> = key key') + ## If the same key is found, I replace the value. + (#Base bitmap (update! idx (#;Right key val) base)) + ## Otherwise, I compare the hashes of the keys. + (#Base bitmap (update! idx + (#;Left (let [hash' (:: Hash<K> hash key')] + (if (=+ hash hash') + ## If the hashes are + ## the same, a new + ## #Collisions node + ## is added. + (#Collisions hash (|> (: (Array [($ 0) ($ 1)]) + (array;new +2)) + (array;put +0 [key' val']) + (array;put +1 [key val]))) + ## Otherwise, I can + ## just keep using + ## #Base nodes, so I + ## add both KV pairs + ## to the empty one. + (let [next-level (level-up level)] + (|> empty + (put' next-level hash' key' val' Hash<K>) + (put' next-level hash key val Hash<K>)))))) + base))))) + ## However, if the BitPosition has not been used yet, I check + ## whether this #Base node is ready for a promotion. + (let [base-count (bitmap-size bitmap)] + (if (>=+ promotion-threshold base-count) + ## If so, I promote it to a #Hierarchy node, and add the new + ## KV-pair as a singleton node to it. + (#Hierarchy (inc+ base-count) + (|> (promote-base put' Hash<K> level bitmap base) + (array;put (level-index level hash) + (put' (level-up level) hash key val Hash<K> empty)))) + ## Otherwise, I just resize the #Base node to accommodate the + ## new KV-pair. + (#Base (set-bit-position bit bitmap) + (insert! (base-index bit bitmap) (#;Right [key val]) base)))))) + + ## For #Collisions nodes, I compare the hashes. + (#Collisions _hash _colls) + (if (=+ hash _hash) + ## If they're equal, that means the new KV contributes to the + ## collisions. + (case (collision-index Hash<K> key _colls) + ## If the key was already present in the collisions-list, it's + ## value gets updated. + (#;Some coll-idx) + (#Collisions _hash (update! coll-idx [key val] _colls)) + + ## Otherwise, the KV-pair is added to the collisions-list. + #;None + (#Collisions _hash (insert! (array;size _colls) [key val] _colls))) + ## If the hashes are not equal, I create a new #Base node that + ## contains the old #Collisions node, plus the new KV-pair. + (|> (#Base (bit-position level _hash) + (|> (: (Base ($ 0) ($ 1)) + (array;new +1)) + (array;put +0 (#;Left node)))) + (put' level hash key val Hash<K>))) + )) + +(def: (remove' level hash key Hash<K> node) + (All [K V] (-> Level Hash-Code K (Hash K) (Node K V) (Node K V))) + (case node + ## For #Hierarchy nodes, find out if there's a valid sub-node for + ## the Hash-Code. + (#Hierarchy h-size h-array) + (let [idx (level-index level hash)] + (case (array;get idx h-array) + ## If not, there's nothing to remove. + #;None + node + + ## But if there is, try to remove the key from the sub-node. + (#;Some sub-node) + (let [sub-node' (remove' (level-up level) hash key Hash<K> sub-node)] + ## Then check if a removal was actually done. + (if (== sub-node sub-node') + ## If not, then there's nothing to change here either. + node + ## But if the sub-removal yielded an empty sub-node... + (if (empty?' sub-node') + ## Check if it's due time for a demotion. + (if (<=+ demotion-threshold h-size) + ## If so, perform it. + (#Base (demote-hierarchy idx [h-size h-array])) + ## Otherwise, just clear the space. + (#Hierarchy (dec+ h-size) (vacant! idx h-array))) + ## But if the sub-removal yielded a non-empty node, then + ## just update the hiearchy branch. + (#Hierarchy h-size (update! idx sub-node' h-array))))))) + + ## For #Base nodes, check whether the BitPosition is set. + (#Base bitmap base) + (let [bit (bit-position level hash)] + (if (bit-position-is-set? bit bitmap) + (let [idx (base-index bit bitmap)] + (case (array;get idx base) + #;None + (undefined) + + ## If set, check if it's a sub-node, and remove the KV + ## from it. + (#;Some (#;Left sub-node)) + (let [sub-node' (remove' (level-up level) hash key Hash<K> sub-node)] + ## Verify that it was removed. + (if (== sub-node sub-node') + ## If not, there's also nothing to change here. + node + ## But if it came out empty... + (if (empty?' sub-node') + ### ... figure out whether that's the only position left. + (if (only-bit-position? bit bitmap) + ## If so, removing it leaves this node empty too. + empty + ## But if not, then just unset the position and + ## remove the node. + (#Base (unset-bit-position bit bitmap) + (remove! idx base))) + ## But, if it didn't come out empty, then the + ## position is kept, and the node gets updated. + (#Base bitmap + (update! idx (#;Left sub-node') base))))) + + ## If, however, there was a KV pair instead of a sub-node. + (#;Some (#;Right [key' val'])) + ## Check if the keys match. + (if (:: Hash<K> = key key') + ## If so, remove the KV pair and unset the BitPosition. + (#Base (unset-bit-position bit bitmap) + (remove! idx base)) + ## Otherwise, there's nothing to remove. + node))) + ## If the BitPosition is not set, there's nothing to remove. + node)) + + ## For #Collisions nodes, It need to find out if the key already existst. + (#Collisions _hash _colls) + (case (collision-index Hash<K> key _colls) + ## If not, then there's nothing to remove. + #;None + node + + ## But if so, then check the size of the collisions list. + (#;Some idx) + (if (=+ +1 (array;size _colls)) + ## If there's only one left, then removing it leaves us with + ## an empty node. + empty + ## Otherwise, just shrink the array by removing the KV pair. + (#Collisions _hash (remove! idx _colls)))) + )) + +(def: (get' level hash key Hash<K> node) + (All [K V] (-> Level Hash-Code K (Hash K) (Node K V) (Maybe V))) + (case node + ## For #Hierarchy nodes, just look-up the key on its children. + (#Hierarchy _size hierarchy) + (case (array;get (level-index level hash) hierarchy) + #;None #;None + (#;Some sub-node) (get' (level-up level) hash key Hash<K> sub-node)) + + ## For #Base nodes, check the leaves, and recursively check the branches. + (#Base bitmap base) + (let [bit (bit-position level hash)] + (if (bit-position-is-set? bit bitmap) + (case (array;get (base-index bit bitmap) base) + #;None + (undefined) + + (#;Some (#;Left sub-node)) + (get' (level-up level) hash key Hash<K> sub-node) + + (#;Some (#;Right [key' val'])) + (if (:: Hash<K> = key key') + (#;Some val') + #;None)) + #;None)) + + ## For #Collisions nodes, do a linear scan of all the known KV-pairs. + (#Collisions _hash _colls) + (:: Monad<Maybe> map product;right + (array;find (|>. product;left (:: Hash<K> = key)) + _colls)) + )) + +(def: (size' node) + (All [K V] (-> (Node K V) Nat)) + (case node + (#Hierarchy _size hierarchy) + (Array/fold ++ +0 (Array/map size' hierarchy)) + + (#Base _ base) + (Array/fold ++ +0 (Array/map (lambda [sub-node'] + (case sub-node' + (#;Left sub-node) (size' sub-node) + (#;Right _) +1)) + base)) + + (#Collisions hash colls) + (array;size colls) + )) + +(def: (entries' node) + (All [K V] (-> (Node K V) (List [K V]))) + (case node + (#Hierarchy _size hierarchy) + (Array/fold (lambda [sub-node tail] (List/append (entries' sub-node) tail)) + #;Nil + hierarchy) + + (#Base bitmap base) + (Array/fold (lambda [branch tail] + (case branch + (#;Left sub-node) + (List/append (entries' sub-node) tail) + + (#;Right [key' val']) + (#;Cons [key' val'] tail))) + #;Nil + base) + + (#Collisions hash colls) + (Array/fold (lambda [[key' val'] tail] (#;Cons [key' val'] tail)) + #;Nil + colls))) + +## [Exports] +(type: #export (Dict k v) + {#;doc "A dictionary implemented as a Hash-Array Mapped Trie (HAMT)."} + {#hash (Hash k) + #root (Node k v)}) + +(def: #export (new Hash<K>) + (All [K V] (-> (Hash K) (Dict K V))) + {#hash Hash<K> + #root empty}) + +(def: #export (put key val [Hash<K> node]) + (All [K V] (-> K V (Dict K V) (Dict K V))) + [Hash<K> (put' root-level (:: Hash<K> hash key) key val Hash<K> node)]) + +(def: #export (remove key [Hash<K> node]) + (All [K V] (-> K (Dict K V) (Dict K V))) + [Hash<K> (remove' root-level (:: Hash<K> hash key) key Hash<K> node)]) + +(def: #export (get key [Hash<K> node]) + (All [K V] (-> K (Dict K V) (Maybe V))) + (get' root-level (:: Hash<K> hash key) key Hash<K> node)) + +(def: #export (contains? key table) + (All [K V] (-> K (Dict K V) Bool)) + (case (get key table) + #;None false + (#;Some _) true)) + +(def: #export (put~ key val table) + {#;doc "Only puts the KV-pair if the key is not already present."} + (All [K V] (-> K V (Dict K V) (Dict K V))) + (if (contains? key table) + table + (put key val table))) + +(def: #export (update key f table) + {#;doc "Transforms the value located at key (if available), using the given function."} + (All [K V] (-> K (-> V V) (Dict K V) (Dict K V))) + (case (get key table) + #;None + table + + (#;Some val) + (put key (f val) table))) + +(def: #export size + (All [K V] (-> (Dict K V) Nat)) + (|>. product;right size')) + +(def: #export empty? + (All [K V] (-> (Dict K V) Bool)) + (|>. size (=+ +0))) + +(def: #export (entries dict) + (All [K V] (-> (Dict K V) (List [K V]))) + (entries' (product;right dict))) + +(def: #export (from-list Hash<K> kvs) + (All [K V] (-> (Hash K) (List [K V]) (Dict K V))) + (List/fold (lambda [[k v] dict] + (put k v dict)) + (new Hash<K>) + kvs)) + +(do-template [<name> <elem-type> <side>] + [(def: #export <name> + (All [K V] (-> (Dict K V) (List <elem-type>))) + (|>. entries (List/map <side>)))] + + [keys K product;left] + [values V product;right] + ) + +(def: #export (merge dict2 dict1) + (All [K V] (-> (Dict K V) (Dict K V) (Dict K V))) + (List/fold (lambda [[key val] dict] (put key val dict)) + dict1 + (entries dict2))) + +(def: #export (merge-with f dict1 dict2) + (All [K V] (-> (-> V V V) (Dict K V) (Dict K V) (Dict K V))) + (List/fold (lambda [[key val] dict] + (case (get key dict) + #;None + (put key val dict) + + (#;Some val') + (put key (f val' val) dict))) + dict1 + (entries dict2))) + +(def: #export (re-bind from-key to-key dict) + (All [K V] (-> K K (Dict K V) (Dict K V))) + (case (get from-key dict) + #;None + dict + + (#;Some val) + (|> dict + (remove from-key) + (put to-key val)))) + +(def: #export (select keys (^@ old-dict [Hash<K> _])) + {#;doc "Creates a sub-set of the given dict, with only the specified keys."} + (All [K V] (-> (List K) (Dict K V) (Dict K V))) + (List/fold (lambda [key new-dict] + (case (get key old-dict) + #;None new-dict + (#;Some val) (put key val new-dict))) + (new Hash<K>) + keys)) + +## [Structures] +(struct: #export (Eq<Dict> Eq<v>) (All [k v] (-> (Eq v) (Eq (Dict k v)))) + (def: (= test subject) + (and (=+ (size test) + (size subject)) + (list;every? (lambda [k] + (case [(get k test) (get k subject)] + [(#;Some tk) (#;Some sk)] + (:: Eq<v> = tk sk) + + _ + false)) + (keys test))))) diff --git a/stdlib/source/lux/data/struct/list.lux b/stdlib/source/lux/data/struct/list.lux new file mode 100644 index 000000000..7d71e4faa --- /dev/null +++ b/stdlib/source/lux/data/struct/list.lux @@ -0,0 +1,487 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monoid + functor + applicative + ["M" monad #*] + eq + [fold]) + (data [number "Int/" Number<Int> Codec<Text,Int>] + bool + [product]) + codata/function)) + +## [Types] +## (type: (List a) +## #Nil +## (#Cons a (List a))) + +## [Functions] +(struct: #export _ (fold;Fold List) + (def: (fold f init xs) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (fold f (f x init) xs')))) + +(open Fold<List>) + +(def: #export (reverse xs) + (All [a] + (-> (List a) (List a))) + (fold (lambda [head tail] (#;Cons head tail)) + #;Nil + xs)) + +(def: #export (filter p xs) + (All [a] + (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + (if (p x) + (#;Cons [x (filter p xs')]) + (filter p xs')))) + +(def: #export (partition p xs) + (All [a] (-> (-> a Bool) (List a) [(List a) (List a)])) + [(filter p xs) (filter (complement p) xs)]) + +(def: #export (as-pairs xs) + (All [a] (-> (List a) (List [a a]))) + (case xs + (^ (#;Cons [x1 (#;Cons [x2 xs'])])) + (#;Cons [[x1 x2] (as-pairs xs')]) + + _ + #;Nil)) + +(do-template [<name> <then> <else>] + [(def: #export (<name> n xs) + (All [a] + (-> Nat (List a) (List a))) + (if (>+ +0 n) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + <then>) + <else>))] + + [take (#;Cons [x (take (-+ +1 n) xs')]) #;Nil] + [drop (drop (-+ +1 n) xs') xs] + ) + +(do-template [<name> <then> <else>] + [(def: #export (<name> p xs) + (All [a] + (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + (if (p x) + <then> + <else>)))] + + [take-while (#;Cons [x (take-while p xs')]) #;Nil] + [drop-while (drop-while p xs') xs] + ) + +(def: #export (split n xs) + (All [a] + (-> Nat (List a) [(List a) (List a)])) + (if (>+ +0 n) + (case xs + #;Nil + [#;Nil #;Nil] + + (#;Cons [x xs']) + (let [[tail rest] (split (-+ +1 n) xs')] + [(#;Cons [x tail]) rest])) + [#;Nil xs])) + +(def: (split-with' p ys xs) + (All [a] + (-> (-> a Bool) (List a) (List a) [(List a) (List a)])) + (case xs + #;Nil + [ys xs] + + (#;Cons [x xs']) + (if (p x) + (split-with' p (#;Cons [x ys]) xs') + [ys xs]))) + +(def: #export (split-with p xs) + (All [a] + (-> (-> a Bool) (List a) [(List a) (List a)])) + (let [[ys' xs'] (split-with' p #;Nil xs)] + [(reverse ys') xs'])) + +(def: #export (split-all n xs) + (All [a] (-> Nat (List a) (List (List a)))) + (case xs + #;Nil + (list) + + _ + (let [[pre post] (split n xs)] + (#;Cons pre (split-all n post))))) + +(def: #export (repeat n x) + (All [a] + (-> Nat a (List a))) + (if (>+ +0 n) + (#;Cons [x (repeat (dec+ n) x)]) + #;Nil)) + +(def: (iterate' f x) + (All [a] + (-> (-> a (Maybe a)) a (List a))) + (case (f x) + (#;Some x') + (list& x (iterate' f x')) + + #;None + (list))) + +(def: #export (iterate f x) + (All [a] + (-> (-> a (Maybe a)) a (List a))) + (case (f x) + (#;Some x') + (list& x (iterate' f x')) + + #;None + (list x))) + +(def: #export (find p xs) + (All [a] + (-> (-> a Bool) (List a) (Maybe a))) + (case xs + #;Nil + #;None + + (#;Cons [x xs']) + (if (p x) + (#;Some x) + (find p xs')))) + +(def: #export (interpose sep xs) + (All [a] + (-> a (List a) (List a))) + (case xs + #;Nil + xs + + (#;Cons [x #;Nil]) + xs + + (#;Cons [x xs']) + (#;Cons [x (#;Cons [sep (interpose sep xs')])]))) + +(def: #export (size list) + (All [a] (-> (List a) Nat)) + (fold (lambda [_ acc] (++ +1 acc)) +0 list)) + +(do-template [<name> <init> <op>] + [(def: #export (<name> p xs) + (All [a] + (-> (-> a Bool) (List a) Bool)) + (fold (lambda [_2 _1] (<op> _1 (p _2))) <init> xs))] + + [every? true and] + [any? false or]) + +(def: #export (at i xs) + (All [a] + (-> Nat (List a) (Maybe a))) + (case xs + #;Nil + #;None + + (#;Cons [x xs']) + (if (=+ +0 i) + (#;Some x) + (at (-+ +1 i) xs')))) + +## [Structures] +(struct: #export (Eq<List> (^open "a:")) + (All [a] (-> (Eq a) (Eq (List a)))) + (def: (= xs ys) + (case [xs ys] + [#;Nil #;Nil] + true + + [(#;Cons x xs') (#;Cons y ys')] + (and (a:= x y) + (= xs' ys')) + + [_ _] + false + ))) + +(struct: #export Monoid<List> (All [a] + (Monoid (List a))) + (def: unit #;Nil) + (def: (append xs ys) + (case xs + #;Nil ys + (#;Cons x xs') (#;Cons x (append xs' ys))))) + +(open Monoid<List>) + +(struct: #export _ (Functor List) + (def: (map f ma) + (case ma + #;Nil #;Nil + (#;Cons a ma') (#;Cons (f a) (map f ma'))))) + +(open Functor<List>) + +(struct: #export _ (Applicative List) + (def: functor Functor<List>) + + (def: (wrap a) + (#;Cons a #;Nil)) + + (def: (apply ff fa) + (case ff + #;Nil + #;Nil + + (#;Cons f ff') + (append (map f fa) (apply ff' fa))))) + +(struct: #export _ (Monad List) + (def: applicative Applicative<List>) + + (def: join (|>. reverse (fold append unit)))) + +## [Functions] +(def: #export (sort < xs) + (All [a] (-> (-> a a Bool) (List a) (List a))) + (case xs + #;Nil + (list) + + (#;Cons x xs') + (let [[pre post] (fold (lambda [x' [pre post]] + (if (< x x') + [(#;Cons x' pre) post] + [pre (#;Cons x' post)])) + [(list) (list)] + xs')] + ($_ append (sort < pre) (list x) (sort < post))))) + +(do-template [<name> <type> <comp> <inc>] + [(def: #export (<name> from to) + (-> <type> <type> (List <type>)) + (if (<comp> to from) + (list& from (<name> (<inc> from) to)) + (list)))] + + [range Int <= inc] + [range+ Nat <=+ inc+] + ) + +(def: #export (empty? xs) + (All [a] (-> (List a) Bool)) + (case xs + #;Nil true + _ false)) + +(def: #export (member? eq xs x) + (All [a] (-> (Eq a) (List a) a Bool)) + (case xs + #;Nil false + (#;Cons x' xs') (or (:: eq = x x') + (member? eq xs' x)))) + +(do-template [<name> <output> <side>] + [(def: #export (<name> xs) + (All [a] (-> (List a) (Maybe <output>))) + (case xs + #;Nil + #;None + + (#;Cons x xs') + (#;Some <side>)))] + + [head a x] + [tail (List a) xs'] + ) + +## [Syntax] +(def: (symbol$ name) + (-> Text AST) + [["" -1 -1] (#;SymbolS "" name)]) + +(macro: #export (zip tokens state) + {#;doc (doc "Create list zippers with the specified number of input lists." + (def: #export zip2 (zip 2)) + (def: #export zip3 (zip 3)) + ((zip 3) xs ys zs))} + (case tokens + (^ (list [_ (#;IntS num-lists)])) + (if (> 0 num-lists) + (let [(^open) Functor<List> + indices (range 0 (dec num-lists)) + type-vars (: (List AST) (map (. symbol$ Int/encode) indices)) + zip-type (` (All [(~@ type-vars)] + (-> (~@ (map (: (-> AST AST) (lambda [var] (` (List (~ var))))) + type-vars)) + (List [(~@ type-vars)])))) + vars+lists (|> indices + (map inc) + (map (lambda [idx] + [(symbol$ (Int/encode idx)) + (symbol$ (Int/encode (Int/negate idx)))]))) + pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs)))) + vars+lists))]) + g!step (symbol$ "\tstep\t") + g!blank (symbol$ "\t_\t") + list-vars (map product;right vars+lists) + code (` (: (~ zip-type) + (lambda (~ g!step) [(~@ list-vars)] + (case [(~@ list-vars)] + (~ pattern) + (#;Cons [(~@ (map product;left vars+lists))] + ((~ g!step) (~@ list-vars))) + + (~ g!blank) + #;Nil))))] + (#;Right [state (list code)])) + (#;Left "Can't zip 0 lists.")) + + _ + (#;Left "Wrong syntax for zip"))) + +(def: #export zip2 (zip 2)) +(def: #export zip3 (zip 3)) + +(macro: #export (zip-with tokens state) + {#;doc (doc "Create list zip-with`s with the specified number of input lists." + (def: #export zip2-with (zip-with 2)) + (def: #export zip3-with (zip-with 3)) + ((zip-with 2) + xs ys))} + (case tokens + (^ (list [_ (#;IntS num-lists)])) + (if (> 0 num-lists) + (let [(^open) Functor<List> + indices (range 0 (dec num-lists)) + g!return-type (symbol$ "\treturn-type\t") + g!func (symbol$ "\tfunc\t") + type-vars (: (List AST) (map (. symbol$ Int/encode) indices)) + zip-type (` (All [(~@ type-vars) (~ g!return-type)] + (-> (-> (~@ type-vars) (~ g!return-type)) + (~@ (map (: (-> AST AST) (lambda [var] (` (List (~ var))))) + type-vars)) + (List (~ g!return-type))))) + vars+lists (|> indices + (map inc) + (map (lambda [idx] + [(symbol$ (Int/encode idx)) + (symbol$ (Int/encode (Int/negate idx)))]))) + pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs)))) + vars+lists))]) + g!step (symbol$ "\tstep\t") + g!blank (symbol$ "\t_\t") + list-vars (map product;right vars+lists) + code (` (: (~ zip-type) + (lambda (~ g!step) [(~ g!func) (~@ list-vars)] + (case [(~@ list-vars)] + (~ pattern) + (#;Cons ((~ g!func) (~@ (map product;left vars+lists))) + ((~ g!step) (~ g!func) (~@ list-vars))) + + (~ g!blank) + #;Nil))))] + (#;Right [state (list code)])) + (#;Left "Can't zip-with 0 lists.")) + + _ + (#;Left "Wrong syntax for zip-with"))) + +(def: #export zip2-with (zip-with 2)) +(def: #export zip3-with (zip-with 3)) + +(def: #export (last xs) + (All [a] (-> (List a) (Maybe a))) + (case xs + #;Nil + #;None + + (#;Cons x #;Nil) + (#;Some x) + + (#;Cons x xs') + (last xs'))) + +(def: #export (inits xs) + (All [a] (-> (List a) (Maybe (List a)))) + (case xs + #;Nil + #;None + + (#;Cons x #;Nil) + (#;Some #;Nil) + + (#;Cons x xs') + (case (inits xs') + #;None + (undefined) + + (#;Some tail) + (#;Some (#;Cons x tail))) + )) + +(def: #export (concat xss) + (All [a] (-> (List (List a)) (List a))) + (:: Monad<List> join xss)) + +(struct: #export (ListT Monad<M>) + (All [M] (-> (Monad M) (Monad (All [a] (M (List a)))))) + (def: applicative (compA (get@ #M;applicative Monad<M>) Applicative<List>)) + (def: (join MlMla) + (do Monad<M> + [lMla MlMla + lla (: (($ 0) (List (List ($ 1)))) + (mapM @ join lMla))] + (wrap (concat lla))))) + +(def: #export (lift-list Monad<M>) + (All [M a] (-> (Monad M) (-> (M a) (M (List a))))) + (liftM Monad<M> (:: Monad<List> wrap))) + +(def: (enumerate' idx xs) + (All [a] (-> Nat (List a) (List [Nat a]))) + (case xs + #;Nil + #;Nil + + (#;Cons x xs') + (#;Cons [idx x] (enumerate' (inc+ idx) xs')))) + +(def: #export (enumerate xs) + (All [a] (-> (List a) (List [Nat a]))) + (enumerate' +0 xs)) + +(def: #export (indices size) + {#;doc "Produces all the valid indices for a given size."} + (All [a] (-> Nat (List Nat))) + (if (=+ +0 size) + (list) + (|> size dec+ (range+ +0)))) diff --git a/stdlib/source/lux/data/struct/queue.lux b/stdlib/source/lux/data/struct/queue.lux new file mode 100644 index 000000000..61b97c9cd --- /dev/null +++ b/stdlib/source/lux/data/struct/queue.lux @@ -0,0 +1,79 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control eq) + (data (struct [list "List/" Monoid<List>])))) + +## [Types] +(type: #export (Queue a) + {#front (List a) + #rear (List a)}) + +## [Values] +(def: #export empty + Queue + {#front (list) + #rear (list)}) + +(def: #export (from-list entries) + (All [a] (-> (List a) (Queue a))) + {#front entries + #rear (list)}) + +(def: #export (to-list queue) + (All [a] (-> (Queue a) (List a))) + (let [(^slots [#front #rear]) queue] + (List/append front (list;reverse rear)))) + +(def: #export peek + (All [a] (-> (Queue a) (Maybe a))) + (|>. (get@ #front) list;head)) + +(def: #export (size queue) + (All [a] (-> (Queue a) Nat)) + (let [(^slots [#front #rear]) queue] + (++ (list;size front) + (list;size rear)))) + +(def: #export empty? + (All [a] (-> (Queue a) Bool)) + (|>. (get@ [#front]) list;empty?)) + +(def: #export (enqueued? a/Eq queue member) + (All [a] (-> (Eq a) (Queue a) a Bool)) + (let [(^slots [#front #rear]) queue] + (or (list;member? a/Eq front member) + (list;member? a/Eq rear member)))) + +(def: #export (dequeue queue) + (All [a] (-> (Queue a) (Queue a))) + (case (get@ #front queue) + (^ (list)) ## Empty... + queue + + (^ (list _)) ## Front has dried up... + (|> queue + (set@ #front (list;reverse (get@ #rear queue))) + (set@ #rear (list))) + + (^ (list& _ front')) ## Consume front! + (|> queue + (set@ #front front')))) + +(def: #export (enqueue val queue) + (All [a] (-> a (Queue a) (Queue a))) + (case (get@ #front queue) + #;Nil + (set@ #front (list val) queue) + + _ + (update@ #rear (|>. (#;Cons val)) queue))) + +## [Structures] +(struct: #export (Eq<Queue> Eq<a>) (All [a] (-> (Eq a) (Eq (Queue a)))) + (def: (= qx qy) + (:: (list;Eq<List> Eq<a>) = (to-list qx) (to-list qy)))) diff --git a/stdlib/source/lux/data/struct/set.lux b/stdlib/source/lux/data/struct/set.lux new file mode 100644 index 000000000..085c0f047 --- /dev/null +++ b/stdlib/source/lux/data/struct/set.lux @@ -0,0 +1,85 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + applicative + monad + eq + [hash #*]) + (data (struct [dict] + [list "List/" Fold<List> Functor<List>])) + (codata function))) + +## [Types] +(type: #export (Set a) + (dict;Dict a a)) + +## [Values] +(def: #export (new Hash<a>) + (All [a] (-> (Hash a) (Set a))) + (dict;new Hash<a>)) + +(def: #export (add elem set) + (All [a] (-> a (Set a) (Set a))) + (dict;put elem elem set)) + +(def: #export (remove elem set) + (All [a] (-> a (Set a) (Set a))) + (dict;remove elem set)) + +(def: #export (member? set elem) + (All [a] (-> (Set a) a Bool)) + (dict;contains? elem set)) + +(def: #export (union xs yx) + (All [a] (-> (Set a) (Set a) (Set a))) + (dict;merge xs yx)) + +(def: #export (difference subs base) + (All [a] (-> (Set a) (Set a) (Set a))) + (List/fold remove base (dict;keys subs))) + +(def: #export (intersection filter base) + (All [a] (-> (Set a) (Set a) (Set a))) + (dict;select (dict;keys filter) base)) + +(def: #export (size set) + (All [a] (-> (Set a) Nat)) + (dict;size set)) + +(def: #export (empty? set) + (All [a] (-> (Set a) Bool)) + (=+ +0 (dict;size set))) + +(def: #export to-list + (All [a] (-> (Set a) (List a))) + dict;keys) + +(def: #export (from-list Hash<a> xs) + (All [a] (-> (Hash a) (List a) (Set a))) + (List/fold add (new Hash<a>) xs)) + +(def: #export (sub? super sub) + (All [a] (-> (Set a) (Set a) Bool)) + (list;every? (member? super) (to-list sub))) + +(def: #export (super? sub super) + (All [a] (-> (Set a) (Set a) Bool)) + (sub? super sub)) + +## [Structures] +(struct: #export Eq<Set> (All [a] (Eq (Set a))) + (def: (= (^@ test [Hash<a> _]) subject) + (:: (list;Eq<List> (get@ #hash;eq Hash<a>)) = (to-list test) (to-list subject)))) + +(struct: #export Hash<Set> (All [a] (Hash (Set a))) + (def: eq Eq<Set>) + + (def: (hash (^@ set [Hash<a> _])) + (List/fold (lambda [elem acc] (++ (:: Hash<a> hash elem) acc)) + +0 + (to-list set)))) diff --git a/stdlib/source/lux/data/struct/stack.lux b/stdlib/source/lux/data/struct/stack.lux new file mode 100644 index 000000000..e62a74590 --- /dev/null +++ b/stdlib/source/lux/data/struct/stack.lux @@ -0,0 +1,47 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (data (struct [list])))) + +## [Types] +(type: #export (Stack a) + (List a)) + +## [Values] +(def: #export empty + Stack + (list)) + +(def: #export (size stack) + (All [a] (-> (Stack a) Nat)) + (list;size stack)) + +(def: #export (empty? stack) + (All [a] (-> (Stack a) Bool)) + (list;empty? stack)) + +(def: #export (peek stack) + (All [a] (-> (Stack a) (Maybe a))) + (case stack + #;Nil + #;None + + (#;Cons value _) + (#;Some value))) + +(def: #export (pop stack) + (All [a] (-> (Stack a) (Stack a))) + (case stack + #;Nil + #;Nil + + (#;Cons _ stack') + stack')) + +(def: #export (push value stack) + (All [a] (-> a (Stack a) (Stack a))) + (#;Cons value stack)) diff --git a/stdlib/source/lux/data/struct/tree.lux b/stdlib/source/lux/data/struct/tree.lux new file mode 100644 index 000000000..7b7828d73 --- /dev/null +++ b/stdlib/source/lux/data/struct/tree.lux @@ -0,0 +1,54 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monad + eq) + (data (struct [list "" Monad<List>])) + [compiler] + (macro [ast] + ["s" syntax #+ syntax: Syntax]))) + +## [Types] +(type: #export (Tree a) + {#value a + #children (List (Tree a))}) + +## [Values] +(def: #export (flatten tree) + (All [a] (-> (Tree a) (List a))) + (#;Cons (get@ #value tree) + (join (map flatten (get@ #children tree))))) + +(def: #export (leaf value) + (All [a] (-> a (Tree a))) + {#value value + #children (list)}) + +(def: #export (branch value children) + (All [a] (-> a (List (Tree a)) (Tree a))) + {#value value + #children children}) + +## [Syntax] +(type: #rec Tree-AST + [AST (List Tree-AST)]) + +(def: (tree^ _) + (-> Unit (Syntax Tree-AST)) + (s;record (s;seq s;any (s;tuple (s;some (lambda [state] ((tree^ []) state))))))) + +(syntax: #export (tree type {root (tree^ [])}) + (wrap (list (` (: (Tree (~ type)) + (~ (loop [[value children] root] + (` {#value (~ value) + #children (list (~@ (map recur children)))})))))))) + +## [Structs] +(struct: #export (Eq<Tree> Eq<a>) (All [a] (-> (Eq a) (Eq (Tree a)))) + (def: (= tx ty) + (and (:: Eq<a> = (get@ #value tx) (get@ #value ty)) + (:: (list;Eq<List> (Eq<Tree> Eq<a>)) = (get@ #children tx) (get@ #children ty))))) diff --git a/stdlib/source/lux/data/struct/vector.lux b/stdlib/source/lux/data/struct/vector.lux new file mode 100644 index 000000000..bb31063a4 --- /dev/null +++ b/stdlib/source/lux/data/struct/vector.lux @@ -0,0 +1,428 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + applicative + monad + eq + monoid + fold) + (data maybe + (struct [list "List/" Fold<List> Functor<List> Monoid<List>] + [array #+ Array "Array/" Functor<Array> Fold<Array>]) + [bit] + [number "Int/" Number<Int>] + [product]) + [compiler #+ with-gensyms] + (macro [ast] + ["s" syntax #+ syntax: Syntax]) + [pipe] + )) + +## This implementation of vectors is based on Clojure's +## PersistentVector implementation. + +## [Utils] +(type: (Node a) + (#Base (Array a)) + (#Hierarchy (Array (Node a)))) + +(type: (Base a) (Array a)) +(type: (Hierarchy a) (Array (Node a))) + +(type: Level Nat) + +(type: Index Nat) + +(def: branching-exponent + Nat + +5) + +(def: root-level + Level + +0) + +(do-template [<name> <op>] + [(def: <name> + (-> Level Level) + (<op> branching-exponent))] + + [level-up ++] + [level-down -+] + ) + +(def: full-node-size + Nat + (bit;<< branching-exponent +1)) + +(def: branch-idx-mask + Nat + (dec+ full-node-size)) + +(def: branch-idx + (-> Index Index) + (bit;& branch-idx-mask)) + +(def: (new-hierarchy _) + (All [a] (-> Top (Hierarchy a))) + (array;new full-node-size)) + +(def: (tail-off vec-size) + (-> Nat Nat) + (if (<+ full-node-size vec-size) + +0 + (|> (dec+ vec-size) + (bit;>>> branching-exponent) + (bit;<< branching-exponent)))) + +(def: (new-path level tail) + (All [a] (-> Level (Base a) (Node a))) + (if (=+ +0 level) + (#Base tail) + (|> (: (Hierarchy ($ 0)) + (new-hierarchy [])) + (array;put +0 (new-path (level-down level) tail)) + #Hierarchy))) + +(def: (new-tail singleton) + (All [a] (-> a (Base a))) + (|> (: (Base ($ 0)) + (array;new +1)) + (array;put +0 singleton))) + +(def: (push-tail size level tail parent) + (All [a] (-> Nat Level (Base a) (Hierarchy a) (Hierarchy a))) + (let [sub-idx (branch-idx (bit;>>> level (dec+ size))) + ## If we're currently on a bottom node + sub-node (if (=+ branching-exponent level) + ## Just add the tail to it + (#Base tail) + ## Otherwise, check whether there's a vacant spot + (case (array;get sub-idx parent) + ## If so, set the path to the tail + #;None + (new-path (level-down level) tail) + ## If not, push the tail onto the sub-node. + (#;Some (#Hierarchy sub-node)) + (#Hierarchy (push-tail size (level-down level) tail sub-node)) + + _ + (undefined)) + )] + (|> (array;clone parent) + (array;put sub-idx sub-node)))) + +(def: (expand-tail val tail) + (All [a] (-> a (Base a) (Base a))) + (let [tail-size (array;size tail)] + (|> (: (Base ($ 0)) + (array;new (inc+ tail-size))) + (array;copy tail-size +0 tail +0) + (array;put tail-size val) + ))) + +(def: (put' level idx val hierarchy) + (All [a] (-> Level Index a (Hierarchy a) (Hierarchy a))) + (let [sub-idx (branch-idx (bit;>>> level idx))] + (case (array;get sub-idx hierarchy) + (#;Some (#Hierarchy sub-node)) + (|> (array;clone hierarchy) + (array;put sub-idx (#Hierarchy (put' (level-down level) idx val sub-node)))) + + (^=> (#;Some (#Base base)) + (=+ +0 (level-down level))) + (|> (array;clone hierarchy) + (array;put sub-idx (|> (array;clone base) + (array;put (branch-idx idx) val) + #Base))) + + _ + (undefined)))) + +(def: (pop-tail size level hierarchy) + (All [a] (-> Nat Level (Hierarchy a) (Maybe (Hierarchy a)))) + (let [sub-idx (branch-idx (bit;>>> level (-+ +2 size)))] + (cond (=+ +0 sub-idx) + #;None + + (>+ branching-exponent level) + (do Monad<Maybe> + [base|hierarchy (array;get sub-idx hierarchy) + sub (case base|hierarchy + (#Hierarchy sub) + (pop-tail size (level-down level) sub) + + (#Base _) + (undefined))] + (|> (array;clone hierarchy) + (array;put sub-idx (#Hierarchy sub)) + #;Some)) + + ## Else... + (|> (array;clone hierarchy) + (array;remove sub-idx) + #;Some) + ))) + +(def: (to-list' node) + (All [a] (-> (Node a) (List a))) + (case node + (#Base base) + (array;to-list base) + + (#Hierarchy hierarchy) + (|> hierarchy + array;to-list + list;reverse + (List/fold (lambda [sub acc] (List/append (to-list' sub) acc)) + #;Nil)))) + +## [Types] +(type: #export (Vector a) + {#level Level + #size Nat + #root (Hierarchy a) + #tail (Base a)}) + +## [Exports] +(def: #export empty + Vector + {#level (level-up root-level) + #size +0 + #root (array;new full-node-size) + #tail (array;new +0)}) + +(def: #export (size vector) + (All [a] (-> (Vector a) Nat)) + (get@ #size vector)) + +(def: #export (add val vec) + (All [a] (-> a (Vector a) (Vector a))) + ## Check if there is room in the tail. + (let [vec-size (get@ #size vec)] + (if (|> vec-size (-+ (tail-off vec-size)) (<+ full-node-size)) + ## If so, append to it. + (|> vec + (update@ #size inc+) + (update@ #tail (expand-tail val))) + ## Otherwise, push tail into the tree + ## -------------------------------------------------------- + ## Will the root experience an overflow with this addition? + (|> (if (>+ (bit;<< (get@ #level vec) +1) + (bit;>>> branching-exponent vec-size)) + ## If so, a brand-new root must be established, that is + ## 1-level taller. + (|> vec + (set@ #root (|> (: (Hierarchy ($ 0)) + (new-hierarchy [])) + (array;put +0 (#Hierarchy (get@ #root vec))) + (array;put +1 (new-path (get@ #level vec) (get@ #tail vec))))) + (update@ #level level-up)) + ## Otherwise, just push the current tail onto the root. + (|> vec + (update@ #root (push-tail vec-size (get@ #level vec) (get@ #tail vec))))) + ## Finally, update the size of the Vector and grow a new + ## tail with the new element as it's sole member. + (update@ #size inc+) + (set@ #tail (new-tail val))) + ))) + +(def: (base-for idx vec) + (All [a] (-> Index (Vector a) (Maybe (Base a)))) + (let [vec-size (get@ #size vec)] + (if (and (>=+ +0 idx) + (<+ vec-size idx)) + (if (>=+ (tail-off vec-size) idx) + (#;Some (get@ #tail vec)) + (loop [level (get@ #level vec) + hierarchy (get@ #root vec)] + (case [(>+ branching-exponent level) + (array;get (branch-idx (bit;>>> level idx)) hierarchy)] + [true (#;Some (#Hierarchy sub))] + (recur (level-down level) sub) + + [false (#;Some (#Base base))] + (#;Some base) + + [_ #;None] + #;None + + _ + (error! "Incorrect vector structure.")))) + #;None))) + +(def: #export (at idx vec) + (All [a] (-> Nat (Vector a) (Maybe a))) + (do Monad<Maybe> + [base (base-for idx vec)] + (array;get (branch-idx idx) base))) + +(def: #export (put idx val vec) + (All [a] (-> Nat a (Vector a) (Vector a))) + (let [vec-size (get@ #size vec)] + (if (and (>=+ +0 idx) + (<+ vec-size idx)) + (if (>=+ (tail-off vec-size) idx) + (|> vec + (update@ #tail (: (-> (Base ($ 0)) (Base ($ 0))) + (|>. array;clone (array;put (branch-idx idx) val))))) + (|> vec + (update@ #root (put' (get@ #level vec) idx val)))) + vec))) + +(def: #export (update idx f vec) + (All [a] (-> Nat (-> a a) (Vector a) (Vector a))) + (case (at idx vec) + (#;Some val) + (put idx (f val) vec) + + #;None + vec)) + +(def: #export (pop vec) + (All [a] (-> (Vector a) (Vector a))) + (case (get@ #size vec) + +0 + empty + + +1 + empty + + vec-size + (if (|> vec-size (-+ (tail-off vec-size)) (>+ +1)) + (let [old-tail (get@ #tail vec) + new-tail-size (dec+ (array;size old-tail))] + (|> vec + (update@ #size dec+) + (set@ #tail (|> (array;new new-tail-size) + (array;copy new-tail-size +0 old-tail +0))))) + (default (undefined) + (do Monad<Maybe> + [new-tail (base-for (-+ +2 vec-size) vec) + #let [[level' root'] (: [Level (Hierarchy ($ 0))] + (let [init-level (get@ #level vec)] + (loop [level init-level + root (: (Hierarchy ($ 0)) + (default (new-hierarchy []) + (pop-tail vec-size init-level (get@ #root vec))))] + (if (>+ branching-exponent level) + (case [(array;get +1 root) (array;get +0 root)] + [#;None (#;Some (#Hierarchy sub-node))] + (recur (level-down level) sub-node) + + [#;None (#;Some (#Base _))] + (undefined) + + _ + [level root]) + [level root]))))]] + (wrap (|> vec + (update@ #size dec+) + (set@ #level level') + (set@ #root root') + (set@ #tail new-tail)))))) + )) + +(def: #export (to-list vec) + (All [a] (-> (Vector a) (List a))) + (List/append (to-list' (#Hierarchy (get@ #root vec))) + (to-list' (#Base (get@ #tail vec))))) + +(def: #export (from-list list) + (All [a] (-> (List a) (Vector a))) + (List/fold add + (: (Vector ($ 0)) + empty) + list)) + +(def: #export (member? a/Eq vec val) + (All [a] (-> (Eq a) (Vector a) a Bool)) + (list;member? a/Eq (to-list vec) val)) + +(def: #export empty? + (All [a] (-> (Vector a) Bool)) + (|>. (get@ #size) (=+ +0))) + +## [Syntax] +(syntax: #export (vector {elems (s;some s;any)}) + (wrap (list (` (from-list (list (~@ elems))))))) + +## [Structures] +(struct: #export (Eq<Vector> Eq<a>) (All [a] (-> (Eq a) (Eq (Vector a)))) + (def: (= v1 v2) + (:: (list;Eq<List> Eq<a>) = (to-list v1) (to-list v2)))) + +(struct: _ (Fold Node) + (def: (fold f init xs) + (case xs + (#Base base) + (Array/fold f init base) + + (#Hierarchy hierarchy) + (Array/fold (lambda [node init'] (fold f init' node)) + init + hierarchy)) + )) + +(struct: #export _ (Fold Vector) + (def: (fold f init xs) + (let [(^open) Fold<Node>] + (fold f + (fold f + init + (#Hierarchy (get@ #root xs))) + (#Base (get@ #tail xs)))) + )) + +(struct: #export Monoid<Vector> (All [a] + (Monoid (Vector a))) + (def: unit empty) + (def: (append xs ys) + (List/fold add xs (to-list ys)))) + +(struct: _ (Functor Node) + (def: (map f xs) + (case xs + (#Base base) + (#Base (Array/map f base)) + + (#Hierarchy hierarchy) + (#Hierarchy (Array/map (map f) hierarchy))) + )) + +(struct: #export _ (Functor Vector) + (def: (map f xs) + {#level (get@ #level xs) + #size (get@ #size xs) + #root (|> xs (get@ #root) (Array/map (:: Functor<Node> map f))) + #tail (|> xs (get@ #tail) (Array/map f)) + })) + +(struct: #export _ (Applicative Vector) + (def: functor Functor<Vector>) + + (def: (wrap x) + (vector x)) + + (def: (apply ff fa) + (let [(^open) Functor<Vector> + (^open) Fold<Vector> + (^open) Monoid<Vector> + results (map (lambda [f] (map f fa)) + ff)] + (fold append unit results))) + ) + +(struct: #export _ (Monad Vector) + (def: applicative Applicative<Vector>) + + (def: (join ffa) + (let [(^open) Functor<Vector> + (^open) Fold<Vector> + (^open) Monoid<Vector>] + (fold append unit ffa))) + ) diff --git a/stdlib/source/lux/data/struct/zipper.lux b/stdlib/source/lux/data/struct/zipper.lux new file mode 100644 index 000000000..eb98409b4 --- /dev/null +++ b/stdlib/source/lux/data/struct/zipper.lux @@ -0,0 +1,196 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (data (struct [list "" Monad<List> Fold<List> "List/" Monoid<List>] + [tree #+ Tree] + [stack #+ Stack])) + [compiler] + (macro [ast] + ["s" syntax #+ syntax: Syntax]))) + +## Adapted from the clojure.zip namespace in the Clojure standard library. + +## [Types] +(type: #export (Zipper a) + {#parent (Maybe (Zipper a)) + #lefts (Stack (Tree a)) + #rights (Stack (Tree a)) + #node (Tree a)}) + +## [Values] +(def: #export (from-tree tree) + (All [a] (-> (Tree a) (Zipper a))) + {#parent #;None + #lefts stack;empty + #rights stack;empty + #node tree}) + +(def: #export (to-tree zipper) + (All [a] (-> (Zipper a) (Tree a))) + (get@ #node zipper)) + +(def: #export (value zipper) + (All [a] (-> (Zipper a) a)) + (|> zipper (get@ #node) (get@ #tree;value))) + +(def: #export (children zipper) + (All [a] (-> (Zipper a) (List (Tree a)))) + (|> zipper (get@ #node) (get@ #tree;children))) + +(def: #export (branch? zipper) + (All [a] (-> (Zipper a) Bool)) + (|> zipper children list;empty? not)) + +(def: #export (leaf? zipper) + (All [a] (-> (Zipper a) Bool)) + (|> zipper branch? not)) + +(def: #export (parent zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (get@ #parent zipper)) + +(def: #export (down zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (children zipper) + #;Nil + zipper + + (#;Cons chead ctail) + {#parent (#;Some zipper) + #lefts stack;empty + #rights ctail + #node chead})) + +(def: #export (up zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ #parent zipper) + #;None + zipper + + (#;Some parent) + (|> parent + (update@ #node (: (-> (Tree ($ 0)) (Tree ($ 0))) + (lambda [node] + (set@ #tree;children (List/append (list;reverse (get@ #lefts zipper)) + (#;Cons (get@ #node zipper) + (get@ #rights zipper))) + node))))))) + +(def: #export (root zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (loop [zipper zipper] + (case (get@ #parent zipper) + #;None zipper + (#;Some _) (recur (up zipper))))) + +(do-template [<one-name> <all-name> <side> <op-side>] + [(def: #export (<one-name> zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ <side> zipper) + #;Nil + zipper + + (#;Cons next side') + (|> zipper + (update@ <op-side> (lambda [op-side] + (#;Cons (get@ #node zipper) op-side))) + (set@ <side> side') + (set@ #node next)))) + + (def: #export (<all-name> zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (fold (lambda [_] <one-name>) zipper (get@ <side> zipper)))] + + [right rightmost #rights #lefts] + [left leftmost #lefts #rights] + ) + +(def: #export (set value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (set@ [#node #tree;value] value zipper)) + +(def: #export (update f zipper) + (All [a] (-> (-> a a) (Zipper a) (Zipper a))) + (update@ [#node #tree;value] f zipper)) + +(def: #export (prepend-child value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (update@ [#node #tree;children] + (lambda [children] + (#;Cons (tree;tree ($ 0) {value []}) + children)) + zipper)) + +(def: #export (append-child value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (update@ [#node #tree;children] + (lambda [children] + (List/append children + (list (tree;tree ($ 0) {value []})))) + zipper)) + +(def: #export (remove zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (case (get@ #lefts zipper) + #;Nil + (case (get@ #parent zipper) + #;None + #;None + + (#;Some next) + (#;Some (|> next + (update@ [#node #tree;children] (|>. list;tail (default (list))))))) + + (#;Cons next side) + (#;Some (|> zipper + (set@ #lefts side) + (set@ #node next))))) + +(do-template [<name> <side>] + [(def: #export (<name> value zipper) + (All [a] (-> a (Zipper a) (Maybe (Zipper a)))) + (case (get@ #parent zipper) + #;None + #;None + + _ + (#;Some (|> zipper + (update@ <side> (lambda [side] + (#;Cons (tree;tree ($ 0) {value []}) + side)))))))] + + [insert-left #lefts] + [insert-right #rights] + ) + +(do-template [<name> <h-side> <h-op> <v-op>] + [(def: #export (<name> zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ <h-side> zipper) + #;Nil + (<v-op> zipper) + + _ + (<h-op> zipper)))] + + [next #rights right down] + [prev #lefts left up] + ) + +(def: #export (end? zipper) + (All [a] (-> (Zipper a) Bool)) + (and (list;empty? (get@ #rights zipper)) + (list;empty? (children zipper)))) + +(def: #export (root? zipper) + (All [a] (-> (Zipper a) Bool)) + (case (get@ #parent zipper) + #;None + true + + _ + false)) diff --git a/stdlib/source/lux/data/sum.lux b/stdlib/source/lux/data/sum.lux new file mode 100644 index 000000000..f01d88727 --- /dev/null +++ b/stdlib/source/lux/data/sum.lux @@ -0,0 +1,45 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: lux) + +## [Values] +(do-template [<name> <type> <index>] + [(def: #export (<name> value) + (All [a b] (-> <type> (| a b))) + (<index> value))] + + [left a +0] + [right b +1]) + +(def: #export (either f g s) + (All [a b c] (-> (-> a c) (-> b c) (| a b) c)) + (case s + (+0 x) (f x) + (+1 x) (g x))) + +(do-template [<name> <side> <tag>] + [(def: #export (<name> es) + (All [a b] (-> (List (| a b)) (List <side>))) + (case es + #;Nil #;Nil + (#;Cons (<tag> x) es') (#;Cons [x (<name> es')]) + (#;Cons _ es') (<name> es')))] + + [lefts a +0] + [rights b +1] + ) + +(def: #export (partition xs) + (All [a b] (-> (List (| a b)) [(List a) (List b)])) + (case xs + #;Nil + [#;Nil #;Nil] + + (#;Cons x xs') + (let [[lefts rights] (partition xs')] + (case x + (+0 x') [(#;Cons x' lefts) rights] + (+1 x') [lefts (#;Cons x' rights)])))) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux new file mode 100644 index 000000000..97507ba3b --- /dev/null +++ b/stdlib/source/lux/data/text.lux @@ -0,0 +1,223 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monoid + eq + [ord] + monad + codec + hash) + (data (struct [list]) + maybe))) + +## [Functions] +(def: #export (size x) + (-> Text Nat) + (int-to-nat (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])]))) + +(def: #export (at idx x) + (-> Nat Text (Maybe Char)) + (if (<+ (size x) idx) + (#;Some (_lux_proc ["jvm" "invokevirtual:java.lang.String:charAt:int"] [x (_lux_proc ["jvm" "l2i"] [(nat-to-int idx)])])) + #;None)) + +(def: #export (contains? sub text) + (-> Text Text Bool) + (_lux_proc ["jvm" "invokevirtual:java.lang.String:contains:java.lang.CharSequence"] [text sub])) + +(do-template [<name> <proc>] + [(def: #export (<name> x) + (-> Text Text) + (_lux_proc ["jvm" <proc>] [x]))] + [lower-case "invokevirtual:java.lang.String:toLowerCase:"] + [upper-case "invokevirtual:java.lang.String:toUpperCase:"] + [trim "invokevirtual:java.lang.String:trim:"] + ) + +(def: #export (sub from to x) + (-> Nat Nat Text (Maybe Text)) + (if (and (<+ to from) + (<=+ (size x) to)) + (#;Some (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] + [x + (_lux_proc ["jvm" "l2i"] [(nat-to-int from)]) + (_lux_proc ["jvm" "l2i"] [(nat-to-int to)])])) + #;None)) + +(def: #export (sub' from x) + (-> Nat Text (Maybe Text)) + (sub from (size x) x)) + +(def: #export (replace pattern value template) + (-> Text Text Text Text) + (_lux_proc ["jvm" "invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"] [template pattern value])) + +(do-template [<common> <common-proc> <general> <general-proc>] + [(def: #export (<common> pattern x) + (-> Text Text (Maybe Nat)) + (case (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" <common-proc>] [x pattern])]) + -1 #;None + idx (#;Some (int-to-nat idx)))) + + (def: #export (<general> pattern from x) + (-> Text Nat Text (Maybe Nat)) + (if (<+ (size x) from) + (case (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" <general-proc>] [x pattern (_lux_proc ["jvm" "l2i"] [(nat-to-int from)])])]) + -1 #;None + idx (#;Some (int-to-nat idx))) + #;None))] + + [index-of "invokevirtual:java.lang.String:indexOf:java.lang.String" index-of' "invokevirtual:java.lang.String:indexOf:java.lang.String,int"] + [last-index-of "invokevirtual:java.lang.String:lastIndexOf:java.lang.String" last-index-of' "invokevirtual:java.lang.String:lastIndexOf:java.lang.String,int"] + ) + +(def: #export (starts-with? prefix x) + (-> Text Text Bool) + (case (index-of prefix x) + (#;Some +0) + true + + _ + false)) + +(def: #export (ends-with? postfix x) + (-> Text Text Bool) + (case (last-index-of postfix x) + (#;Some n) + (=+ (size x) + (++ (size postfix) n)) + + _ + false)) + +(def: #export (split at x) + (-> Nat Text (Maybe [Text Text])) + (if (<=+ (size x) at) + (let [pre (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] [x (_lux_proc ["jvm" "l2i"] [0]) (_lux_proc ["jvm" "l2i"] [(nat-to-int at)])]) + post (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int"] [x (_lux_proc ["jvm" "l2i"] [(nat-to-int at)])])] + (#;Some [pre post])) + #;None)) + +(def: #export (split-with token sample) + (-> Text Text (Maybe [Text Text])) + (do Monad<Maybe> + [index (index-of token sample) + [pre post'] (split index sample) + [_ post] (split (size token) post')] + (wrap [pre post]))) + +(def: #export (split-all-with token sample) + (-> Text Text (List Text)) + (case (split-with token sample) + (#;Some [pre post]) + (#;Cons pre (split-all-with token post)) + + #;None + (#;Cons sample #;Nil))) + +(def: #export split-lines + (split-all-with "\n")) + +## [Structures] +(struct: #export _ (Eq Text) + (def: (= test subject) + (_lux_proc ["jvm" "invokevirtual:java.lang.Object:equals:java.lang.Object"] [subject test]))) + +(struct: #export _ (ord;Ord Text) + (def: eq Eq<Text>) + + (do-template [<name> <op>] + [(def: (<name> test subject) + (<op> 0 + (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:compareTo:java.lang.String"] [subject test])])))] + + [< ;<] + [<= ;<=] + [> ;>] + [>= ;>=])) + +(struct: #export _ (Monoid Text) + (def: unit "") + (def: (append x y) + (_lux_proc ["jvm" "invokevirtual:java.lang.String:concat:java.lang.String"] [x y]))) + +(open Monoid<Text>) + +(struct: #export _ (Codec Text Text) + (def: (encode original) + (let [escaped (|> original + (replace "\\" "\\\\") + (replace "\t" "\\t") + (replace "\b" "\\b") + (replace "\n" "\\n") + (replace "\r" "\\r") + (replace "\f" "\\f") + (replace "\"" "\\\"") + )] + ($_ append "\"" escaped "\""))) + + (def: (decode input) + (if (and (starts-with? "\"" input) + (ends-with? "\"" input)) + (case (sub +1 (dec+ (size input)) input) + (#;Some input') + (|> input' + (replace "\\\\" "\\") + (replace "\\t" "\t") + (replace "\\b" "\b") + (replace "\\n" "\n") + (replace "\\r" "\r") + (replace "\\f" "\f") + (replace "\\\"" "\"") + #;Some) + + #;None + (#;Left "Couldn't decode text")) + (#;Left "Couldn't decode text")))) + +(struct: #export _ (Hash Text) + (def: eq Eq<Text>) + + (def: hash + (|>. [] + (_lux_proc ["jvm" "invokevirtual:java.lang.Object:hashCode:"]) + [] + (_lux_proc ["jvm" "i2l"]) + int-to-nat))) + +(def: #export concat + (-> (List Text) Text) + (let [(^open) list;Fold<List> + (^open) Monoid<Text>] + (|>. list;reverse (fold append unit)))) + +(def: #export (join-with sep texts) + (-> Text (List Text) Text) + (|> texts (list;interpose sep) concat)) + +(def: #export (empty? text) + (-> Text Bool) + (case text + "" true + _ false)) + +(def: #export (replace-once pattern value template) + (-> Text Text Text Text) + (default template + (do Monad<Maybe> + [[pre post] (split-with pattern template)] + (let [(^open) Monoid<Text>] + (wrap ($_ append pre value post)))))) + +(def: #export (enclose [left right] content) + (-> [Text Text] Text Text) + (let [(^open) Monoid<Text>] + ($_ append left content right))) + +(def: #export (enclose' boundary content) + (-> Text Text Text) + (enclose [boundary boundary] content)) diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux new file mode 100644 index 000000000..a8b289fe3 --- /dev/null +++ b/stdlib/source/lux/data/text/format.lux @@ -0,0 +1,54 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monad) + (data [bool] + [char] + [number] + [text] + [ident] + (struct [list "" Monad<List>])) + [type] + [compiler] + (macro [ast] + ["s" syntax #+ syntax: Syntax]))) + +## [Syntax] +(def: #hidden _append_ + (-> Text Text Text) + (:: text;Monoid<Text> append)) + +(syntax: #export (format {fragments (s;many s;any)}) + {#;doc (doc "Text interpolation as a macro." + (format "Static part " (%t static) " doesn't match URI: " uri))} + (wrap (list (` ($_ _append_ (~@ fragments)))))) + +## [Formatters] +(type: (Formatter a) + (-> a Text)) + +(do-template [<name> <type> <formatter>] + [(def: #export <name> + (Formatter <type>) + <formatter>)] + + [%b Bool (:: bool;Codec<Text,Bool> encode)] + [%n Nat (:: number;Codec<Text,Nat> encode)] + [%i Int (:: number;Codec<Text,Int> encode)] + [%f Frac (:: number;Codec<Text,Frac> encode)] + [%r Real (:: number;Codec<Text,Real> encode)] + [%c Char (:: char;Codec<Text,Char> encode)] + [%t Text (:: text;Codec<Text,Text> encode)] + [%ident Ident (:: ident;Codec<Text,Ident> encode)] + [%ast AST ast;ast-to-text] + [%type Type type;type-to-text] + ) + +(def: #export (%list formatter) + (All [a] (-> (Formatter a) (Formatter (List a)))) + (lambda [values] + (format "(list " (text;join-with " " (map formatter values)) ")"))) diff --git a/stdlib/source/lux/host.lux b/stdlib/source/lux/host.lux new file mode 100644 index 000000000..ecc33227a --- /dev/null +++ b/stdlib/source/lux/host.lux @@ -0,0 +1,2137 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monad + [enum]) + (codata function + [io #+ IO Monad<IO> io]) + (data (struct [list #* "" Functor<List> Fold<List> "List/" Monad<List> Monoid<List>] + [array #+ Array]) + number + maybe + [product] + [text "Text/" Eq<Text>] + text/format + [bool "Bool/" Codec<Text,Bool>]) + [compiler #+ with-gensyms Functor<Lux> Monad<Lux>] + (macro [ast] + ["s" syntax #+ syntax: Syntax]) + [type] + )) + +(do-template [<name> <op> <from> <to>] + [(def: #export (<name> value) + {#;doc (doc "Type converter." + "From:" + <from> + "To:" + <to>)} + (-> (host <from>) (host <to>)) + (_lux_proc ["jvm" <op>] [value]))] + + [b2l "b2l" java.lang.Byte java.lang.Long] + + [s2l "s2l" java.lang.Short java.lang.Long] + + [d2i "d2i" java.lang.Double java.lang.Integer] + [d2l "d2l" java.lang.Double java.lang.Long] + [d2f "d2f" java.lang.Double java.lang.Float] + + [f2i "f2i" java.lang.Float java.lang.Integer] + [f2l "f2l" java.lang.Float java.lang.Long] + [f2d "f2d" java.lang.Float java.lang.Double] + + [i2b "i2b" java.lang.Integer java.lang.Byte] + [i2s "i2s" java.lang.Integer java.lang.Short] + [i2l "i2l" java.lang.Integer java.lang.Long] + [i2f "i2f" java.lang.Integer java.lang.Float] + [i2d "i2d" java.lang.Integer java.lang.Double] + [i2c "i2c" java.lang.Integer java.lang.Character] + + [l2b "l2b" java.lang.Long java.lang.Byte] + [l2s "l2s" java.lang.Long java.lang.Short] + [l2i "l2i" java.lang.Long java.lang.Integer] + [l2f "l2f" java.lang.Long java.lang.Float] + [l2d "l2d" java.lang.Long java.lang.Double] + + [c2b "c2b" java.lang.Character java.lang.Byte] + [c2s "c2s" java.lang.Character java.lang.Short] + [c2i "c2i" java.lang.Character java.lang.Integer] + [c2l "c2l" java.lang.Character java.lang.Long] + ) + +## [Utils] +(def: array-type-name "#Array") +(def: constructor-method-name "<init>") +(def: member-separator ".") + +## Types +(do-template [<class> <name>] + [(type: #export <name> + (#;HostT <class> #;Nil))] + + ["[Z" BooleanArray] + ["[B" ByteArray] + ["[S" ShortArray] + ["[I" IntArray] + ["[J" LongArray] + ["[F" FloatArray] + ["[D" DoubleArray] + ["[C" CharArray] + ) + +(type: Code Text) + +(type: BoundKind + #UpperBound + #LowerBound) + +(type: #rec GenericType + (#GenericTypeVar Text) + (#GenericClass [Text (List GenericType)]) + (#GenericArray GenericType) + (#GenericWildcard (Maybe [BoundKind GenericType]))) + +(type: TypeParam + [Text (List GenericType)]) + +(type: Primitive-Mode + #ManualPrM + #AutoPrM) + +(type: PrivacyModifier + #PublicPM + #PrivatePM + #ProtectedPM + #DefaultPM) + +(type: StateModifier + #VolatileSM + #FinalSM + #DefaultSM) + +(type: InheritanceModifier + #FinalIM + #AbstractIM + #DefaultIM) + +(type: ClassKind + #Class + #Interface) + +(type: ClassDecl + {#class-name Text + #class-params (List TypeParam)}) + +(type: StackFrame (host java.lang.StackTraceElement)) +(type: StackTrace (Array StackFrame)) + +(type: SuperClassDecl + {#super-class-name Text + #super-class-params (List GenericType)}) + +(type: AnnotationParam + [Text AST]) + +(type: Annotation + {#ann-name Text + #ann-params (List AnnotationParam)}) + +(type: MemberDecl + {#member-name Text + #member-privacy PrivacyModifier + #member-anns (List Annotation)}) + +(type: FieldDecl + (#ConstantField GenericType AST) + (#VariableField StateModifier GenericType)) + +(type: MethodDecl + {#method-tvars (List TypeParam) + #method-inputs (List GenericType) + #method-output GenericType + #method-exs (List GenericType)}) + +(type: ArgDecl + {#arg-name Text + #arg-type GenericType}) + +(type: ConstructorArg + [GenericType AST]) + +(type: MethodDef + (#ConstructorMethod [Bool + (List TypeParam) + (List ArgDecl) + (List ConstructorArg) + AST + (List GenericType)]) + (#VirtualMethod [Bool + Bool + (List TypeParam) + (List ArgDecl) + GenericType + AST + (List GenericType)]) + (#OverridenMethod [Bool + ClassDecl + (List TypeParam) + (List ArgDecl) + GenericType + AST + (List GenericType)]) + (#StaticMethod [Bool + (List TypeParam) + (List ArgDecl) + GenericType + AST + (List GenericType)]) + (#AbstractMethod [(List TypeParam) + (List ArgDecl) + GenericType + (List GenericType)]) + (#NativeMethod [(List TypeParam) + (List ArgDecl) + GenericType + (List GenericType)])) + +(type: PartialCall + {#pc-method AST + #pc-args AST}) + +(type: ImportMethodKind + #StaticIMK + #VirtualIMK) + +(type: ImportMethodCommons + {#import-member-mode Primitive-Mode + #import-member-alias Text + #import-member-kind ImportMethodKind + #import-member-tvars (List TypeParam) + #import-member-args (List [Bool GenericType]) + #import-member-maybe? Bool + #import-member-try? Bool + #import-member-io? Bool}) + +(type: ImportConstructorDecl + {}) + +(type: ImportMethodDecl + {#import-method-name Text + #import-method-return GenericType}) + +(type: ImportFieldDecl + {#import-field-mode Primitive-Mode + #import-field-name Text + #import-field-static? Bool + #import-field-maybe? Bool + #import-field-setter? Bool + #import-field-type GenericType}) + +(type: ImportMemberDecl + (#EnumDecl (List Text)) + (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl]) + (#MethodDecl [ImportMethodCommons ImportMethodDecl]) + (#FieldAccessDecl ImportFieldDecl)) + +(type: ClassImports + (List [Text Text])) + +## Utils +(def: (short-class-name name) + (-> Text Text) + (case (reverse (text;split-all-with "." name)) + (#;Cons short-name _) + short-name + + #;Nil + name)) + +(def: (manual-primitive-to-type class) + (-> Text (Maybe AST)) + (case class + (^template [<prim> <type>] + <prim> + (#;Some (' <type>))) + (["boolean" (;^ java.lang.Boolean)] + ["byte" (;^ java.lang.Byte)] + ["short" (;^ java.lang.Short)] + ["int" (;^ java.lang.Integer)] + ["long" (;^ java.lang.Long)] + ["float" (;^ java.lang.Float)] + ["double" (;^ java.lang.Double)] + ["char" (;^ java.lang.Character)] + ["void" ;Unit]) + + _ + #;None)) + +(def: (auto-primitive-to-type class) + (-> Text (Maybe AST)) + (case class + (^template [<prim> <type>] + <prim> + (#;Some (' <type>))) + (["boolean" ;Bool] + ["byte" ;Int] + ["short" ;Int] + ["int" ;Int] + ["long" ;Int] + ["float" ;Real] + ["double" ;Real] + ["char" ;Char] + ["void" ;Unit]) + + _ + #;None)) + +(def: (generic-class->type' mode type-params in-array? name+params + class->type') + (-> Primitive-Mode (List TypeParam) Bool [Text (List GenericType)] + (-> Primitive-Mode (List TypeParam) Bool GenericType AST) + AST) + (case [name+params mode in-array?] + (^=> [[prim #;Nil] #ManualPrM false] + {(manual-primitive-to-type prim) (#;Some output)}) + output + + (^=> [[prim #;Nil] #AutoPrM false] + {(auto-primitive-to-type prim) (#;Some output)}) + output + + [[name params] _ _] + (let [=params (map (class->type' mode type-params in-array?) params)] + (` (host (~ (ast;symbol ["" name])) [(~@ =params)]))))) + +(def: (class->type' mode type-params in-array? class) + (-> Primitive-Mode (List TypeParam) Bool GenericType AST) + (case class + (#GenericTypeVar name) + (case (find (lambda [[pname pbounds]] + (and (Text/= name pname) + (not (list;empty? pbounds)))) + type-params) + #;None + (ast;symbol ["" name]) + + (#;Some [pname pbounds]) + (class->type' mode type-params in-array? (default (undefined) (list;head pbounds)))) + + (#GenericClass name+params) + (generic-class->type' mode type-params in-array? name+params + class->type') + + (#GenericArray param) + (let [=param (class->type' mode type-params true param)] + (` (host (~ (ast;symbol ["" array-type-name])) [(~ =param)]))) + + (^or (#GenericWildcard #;None) (#GenericWildcard (#;Some [#LowerBound _]))) + (' (;Ex [*] *)) + + (#GenericWildcard (#;Some [#UpperBound upper-bound])) + (class->type' mode type-params in-array? upper-bound) + )) + +(def: (class->type mode type-params class) + (-> Primitive-Mode (List TypeParam) GenericType AST) + (class->type' mode type-params false class)) + +(def: (type-param-type$ [name bounds]) + (-> TypeParam AST) + (ast;symbol ["" name])) + +(def: (class-decl-type$ (^slots [#class-name #class-params])) + (-> ClassDecl AST) + (let [=params (map (: (-> TypeParam AST) + (lambda [[pname pbounds]] + (case pbounds + #;Nil + (ast;symbol ["" pname]) + + (#;Cons bound1 _) + (class->type #ManualPrM class-params bound1)))) + class-params)] + (` (host (~ (ast;symbol ["" class-name])) [(~@ =params)])))) + +(def: (stack-trace->text trace) + (-> StackTrace Text) + (let [size (_lux_proc ["jvm" "arraylength"] [trace]) + idxs (list;range+ +0 (dec+ size))] + (|> idxs + (map (: (-> Nat Text) + (lambda [idx] + (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] + [(_lux_proc ["jvm" "aaload"] [trace idx])])))) + reverse + (text;join-with "\n") + ))) + +(def: (get-stack-trace t) + (-> (host java.lang.Throwable) StackTrace) + (_lux_proc ["jvm" "invokevirtual:java.lang.Throwable:getStackTrace:"] [t])) + +(def: #export (throwable->text t) + (All [a] (-> (host java.lang.Throwable) (Either Text a))) + (#;Left (format (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [t]) + "\n" + (|> t get-stack-trace stack-trace->text)))) + +(def: empty-imports + ClassImports + (list)) + +(def: (get-import name imports) + (-> Text ClassImports (Maybe Text)) + (:: Functor<Maybe> map product;right + (find (|>. product;left (Text/= name)) + imports))) + +(def: (add-import short+full imports) + (-> [Text Text] ClassImports ClassImports) + (#;Cons short+full imports)) + +(def: (class-imports compiler) + (-> Compiler ClassImports) + (case (compiler;run compiler + (: (Lux ClassImports) + (do Monad<Lux> + [current-module compiler;current-module-name + defs (compiler;defs current-module)] + (wrap (fold (: (-> [Text Def] ClassImports ClassImports) + (lambda [[short-name [_ meta _]] imports] + (case (compiler;get-text-ann (ident-for #;;jvm-class) meta) + (#;Some full-class-name) + (add-import [short-name full-class-name] imports) + + _ + imports))) + empty-imports + defs))))) + (#;Left _) (list) + (#;Right imports) imports)) + +(def: java.lang-classes + (List Text) + (list ## Interfaces + "Appendable" + "AutoCloseable" + "CharSequence" + "Cloneable" + "Comparable" + "Iterable" + "Readable" + "Runnable" + + ## Classes + "Boolean" + "Byte" + "Character" + "Class" + "ClassLoader" + "ClassValue" + "Compiler" + "Double" + "Enum" + "Float" + "InheritableThreadLocal" + "Integer" + "Long" + "Math" + "Number" + "Object" + "Package" + "Process" + "ProcessBuilder" + "Runtime" + "RuntimePermission" + "SecurityManager" + "Short" + "StackTraceElement" + "StrictMath" + "String" + "StringBuffer" + "StringBuilder" + "System" + "Thread" + "ThreadGroup" + "ThreadLocal" + "Throwable" + "Void" + + ## Exceptions + "ArithmeticException" + "ArrayIndexOutOfBoundsException" + "ArrayStoreException" + "ClassCastException" + "ClassNotFoundException" + "CloneNotSupportedException" + "EnumConstantNotPresentException" + "Exception" + "IllegalAccessException" + "IllegalArgumentException" + "IllegalMonitorStateException" + "IllegalStateException" + "IllegalThreadStateException" + "IndexOutOfBoundsException" + "InstantiationException" + "InterruptedException" + "NegativeArraySizeException" + "NoSuchFieldException" + "NoSuchMethodException" + "NullPointerException" + "NumberFormatException" + "ReflectiveOperationException" + "RuntimeException" + "SecurityException" + "StringIndexOutOfBoundsException" + "TypeNotPresentException" + "UnsupportedOperationException" + + ## Annotations + "Deprecated" + "Override" + "SafeVarargs" + "SuppressWarnings")) + +(def: (fully-qualified-class-name? name) + (-> Text Bool) + (text;contains? "." name)) + +(def: (fully-qualify-class-name imports name) + (-> ClassImports Text Text) + (cond (fully-qualified-class-name? name) + name + + (member? text;Eq<Text> java.lang-classes name) + (format "java.lang." name) + + ## else + (default name (get-import name imports)))) + +(def: type-var-class Text "java.lang.Object") + +(def: (simple-class$ params class) + (-> (List TypeParam) GenericType Text) + (case class + (#GenericTypeVar name) + (case (find (lambda [[pname pbounds]] + (and (Text/= name pname) + (not (list;empty? pbounds)))) + params) + #;None + type-var-class + + (#;Some [pname pbounds]) + (simple-class$ params (default (undefined) (list;head pbounds)))) + + (^or (#GenericWildcard #;None) (#GenericWildcard (#;Some [#LowerBound _]))) + type-var-class + + (#GenericWildcard (#;Some [#UpperBound upper-bound])) + (simple-class$ params upper-bound) + + (#GenericClass name params) + name + + (#GenericArray param') + (case param' + (#GenericArray param) + (format "[" (simple-class$ params param)) + + (^template [<prim> <class>] + (#GenericClass <prim> #;Nil) + <class>) + (["boolean" "[Z"] + ["byte" "[B"] + ["short" "[S"] + ["int" "[I"] + ["long" "[J"] + ["float" "[F"] + ["double" "[D"] + ["char" "[C"]) + + param + (format "[L" (simple-class$ params param) ";")) + )) + +(def: (make-get-const-parser class-name field-name) + (-> Text Text (Syntax AST)) + (do s;Monad<Syntax> + [#let [dotted-name (format "." field-name)] + _ (s;symbol! ["" dotted-name])] + (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" class-name ":" field-name)))] []))))) + +(def: (make-get-var-parser class-name field-name) + (-> Text Text (Syntax AST)) + (do s;Monad<Syntax> + [#let [dotted-name (format "." field-name)] + _ (s;symbol! ["" dotted-name])] + (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "getfield" ":" class-name ":" field-name)))] [_jvm_this]))))) + +(def: (make-put-var-parser class-name field-name) + (-> Text Text (Syntax AST)) + (do s;Monad<Syntax> + [#let [dotted-name (format "." field-name)] + [_ _ value] (: (Syntax [Unit Unit AST]) + (s;form ($_ s;seq (s;symbol! ["" ":="]) (s;symbol! ["" dotted-name]) s;any)))] + (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "putfield" ":" class-name ":" field-name)))] [_jvm_this (~ value)]))))) + +(def: (pre-walk-replace f input) + (-> (-> AST AST) AST AST) + (case (f input) + (^template [<tag>] + [meta (<tag> parts)] + [meta (<tag> (map (pre-walk-replace f) parts))]) + ([#;FormS] + [#;TupleS]) + + [meta (#;RecordS pairs)] + [meta (#;RecordS (map (: (-> [AST AST] [AST AST]) + (lambda [[key val]] + [(pre-walk-replace f key) (pre-walk-replace f val)])) + pairs))] + + ast' + ast')) + +(def: (parser->replacer p ast) + (-> (Syntax AST) (-> AST AST)) + (case (s;run (list ast) p) + (#;Right [#;Nil ast']) + ast' + + _ + ast + )) + +(def: (field->parser class-name [[field-name _ _] field]) + (-> Text [MemberDecl FieldDecl] (Syntax AST)) + (case field + (#ConstantField _) + (make-get-const-parser class-name field-name) + + (#VariableField _) + (s;either (make-get-var-parser class-name field-name) + (make-put-var-parser class-name field-name)))) + +(def: (make-constructor-parser params class-name arg-decls) + (-> (List TypeParam) Text (List ArgDecl) (Syntax AST)) + (do s;Monad<Syntax> + [[_ args] (: (Syntax [Unit (List AST)]) + (s;form ($_ s;seq (s;symbol! ["" ".new!"]) (s;tuple (s;exactly (list;size arg-decls) s;any))))) + #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] + (wrap (` (;_lux_proc ["jvm" (~ (ast;text (format "new" ":" class-name ":" (text;join-with "," arg-decls'))))] + [(~@ args)]))))) + +(def: (make-static-method-parser params class-name method-name arg-decls) + (-> (List TypeParam) Text Text (List ArgDecl) (Syntax AST)) + (do s;Monad<Syntax> + [#let [dotted-name (format "." method-name "!")] + [_ args] (: (Syntax [Unit (List AST)]) + (s;form ($_ s;seq (s;symbol! ["" dotted-name]) (s;tuple (s;exactly (list;size arg-decls) s;any))))) + #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] + (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format "invokestatic" ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))] + [(~@ args)]))))) + +(do-template [<name> <jvm-op>] + [(def: (<name> params class-name method-name arg-decls) + (-> (List TypeParam) Text Text (List ArgDecl) (Syntax AST)) + (do s;Monad<Syntax> + [#let [dotted-name (format "." method-name "!")] + [_ args] (: (Syntax [Unit (List AST)]) + (s;form ($_ s;seq (s;symbol! ["" dotted-name]) (s;tuple (s;exactly (list;size arg-decls) s;any))))) + #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] + (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format <jvm-op> ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))] + [(~' _jvm_this) (~@ args)])))))] + + [make-special-method-parser "invokespecial"] + [make-virtual-method-parser "invokevirtual"] + ) + +(def: (method->parser params class-name [[method-name _ _] meth-def]) + (-> (List TypeParam) Text [MemberDecl MethodDef] (Syntax AST)) + (case meth-def + (#ConstructorMethod strict? type-vars args constructor-args return-expr exs) + (make-constructor-parser params class-name args) + + (#StaticMethod strict? type-vars args return-type return-expr exs) + (make-static-method-parser params class-name method-name args) + + (^or (#VirtualMethod final? strict? type-vars args return-type return-expr exs) (#OverridenMethod strict? owner-class type-vars args return-type return-expr exs)) + (make-special-method-parser params class-name method-name args) + + (#AbstractMethod type-vars args return-type exs) + (make-virtual-method-parser params class-name method-name args) + + (#NativeMethod type-vars args return-type exs) + (make-virtual-method-parser params class-name method-name args))) + +## Syntaxs +(def: (full-class-name^ imports) + (-> ClassImports (Syntax Text)) + (do s;Monad<Syntax> + [name s;local-symbol] + (wrap (fully-qualify-class-name imports name)))) + +(def: privacy-modifier^ + (Syntax PrivacyModifier) + (let [(^open) s;Monad<Syntax>] + ($_ s;alt + (s;tag! ["" "public"]) + (s;tag! ["" "private"]) + (s;tag! ["" "protected"]) + (wrap [])))) + +(def: inheritance-modifier^ + (Syntax InheritanceModifier) + (let [(^open) s;Monad<Syntax>] + ($_ s;alt + (s;tag! ["" "final"]) + (s;tag! ["" "abstract"]) + (wrap [])))) + +(def: bound-kind^ + (Syntax BoundKind) + (s;alt (s;symbol! ["" "<"]) + (s;symbol! ["" ">"]))) + +(def: (generic-type^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax GenericType)) + ($_ s;either + (do s;Monad<Syntax> + [_ (s;symbol! ["" "?"])] + (wrap (#GenericWildcard #;None))) + (s;tuple (do s;Monad<Syntax> + [_ (s;symbol! ["" "?"]) + bound-kind bound-kind^ + bound (generic-type^ imports type-vars)] + (wrap (#GenericWildcard (#;Some [bound-kind bound]))))) + (do s;Monad<Syntax> + [name (full-class-name^ imports)] + (let% [<branches> (do-template [<class> <name>] + [(Text/= <name> name) + (wrap (#GenericClass <class> (list)))] + + ["[Z" "BooleanArray"] + ["[B" "ByteArray"] + ["[S" "ShortArray"] + ["[I" "IntArray"] + ["[J" "LongArray"] + ["[F" "FloatArray"] + ["[D" "DoubleArray"] + ["[C" "CharArray"])] + (cond (member? text;Eq<Text> (map product;left type-vars) name) + (wrap (#GenericTypeVar name)) + + <branches> + + ## else + (wrap (#GenericClass name (list)))))) + (s;form (do s;Monad<Syntax> + [name (s;symbol! ["" "Array"]) + component (generic-type^ imports type-vars)] + (case component + (^template [<class> <name>] + (#GenericClass <name> #;Nil) + (wrap (#GenericClass <class> (list)))) + (["[Z" "boolean"] + ["[B" "byte"] + ["[S" "short"] + ["[I" "int"] + ["[J" "long"] + ["[F" "float"] + ["[D" "double"] + ["[C" "char"]) + + _ + (wrap (#GenericArray component))))) + (s;form (do s;Monad<Syntax> + [name (full-class-name^ imports) + params (s;some (generic-type^ imports type-vars)) + _ (s;assert (not (member? text;Eq<Text> (map product;left type-vars) name)) + (format name " can't be a type-parameter!"))] + (wrap (#GenericClass name params)))) + )) + +(def: (type-param^ imports) + (-> ClassImports (Syntax TypeParam)) + (s;either (do s;Monad<Syntax> + [param-name s;local-symbol] + (wrap [param-name (list)])) + (s;tuple (do s;Monad<Syntax> + [param-name s;local-symbol + _ (s;symbol! ["" "<"]) + bounds (s;many (generic-type^ imports (list)))] + (wrap [param-name bounds]))))) + +(def: (type-params^ imports) + (-> ClassImports (Syntax (List TypeParam))) + (s;tuple (s;some (type-param^ imports)))) + +(def: (class-decl^ imports) + (-> ClassImports (Syntax ClassDecl)) + (s;either (do s;Monad<Syntax> + [name (full-class-name^ imports)] + (wrap [name (list)])) + (s;form (do s;Monad<Syntax> + [name (full-class-name^ imports) + params (s;some (type-param^ imports))] + (wrap [name params]))) + )) + +(def: (super-class-decl^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax SuperClassDecl)) + (s;either (do s;Monad<Syntax> + [name (full-class-name^ imports)] + (wrap [name (list)])) + (s;form (do s;Monad<Syntax> + [name (full-class-name^ imports) + params (s;some (generic-type^ imports type-vars))] + (wrap [name params]))))) + +(def: annotation-params^ + (Syntax (List AnnotationParam)) + (s;record (s;some (s;seq s;local-tag s;any)))) + +(def: (annotation^ imports) + (-> ClassImports (Syntax Annotation)) + (s;either (do s;Monad<Syntax> + [ann-name (full-class-name^ imports)] + (wrap [ann-name (list)])) + (s;form (s;seq (full-class-name^ imports) + annotation-params^)))) + +(def: (annotations^' imports) + (-> ClassImports (Syntax (List Annotation))) + (do s;Monad<Syntax> + [_ (s;tag! ["" "ann"])] + (s;tuple (s;some (annotation^ imports))))) + +(def: (annotations^ imports) + (-> ClassImports (Syntax (List Annotation))) + (do s;Monad<Syntax> + [anns?? (s;opt (annotations^' imports))] + (wrap (default (list) anns??)))) + +(def: (throws-decl'^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax (List GenericType))) + (do s;Monad<Syntax> + [_ (s;tag! ["" "throws"])] + (s;tuple (s;some (generic-type^ imports type-vars))))) + +(def: (throws-decl^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax (List GenericType))) + (do s;Monad<Syntax> + [exs? (s;opt (throws-decl'^ imports type-vars))] + (wrap (default (list) exs?)))) + +(def: (method-decl^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDecl])) + (s;form (do s;Monad<Syntax> + [tvars (s;default (list) (type-params^ imports)) + name s;local-symbol + anns (annotations^ imports) + inputs (s;tuple (s;some (generic-type^ imports type-vars))) + output (generic-type^ imports type-vars) + exs (throws-decl^ imports type-vars)] + (wrap [[name #PublicPM anns] {#method-tvars tvars + #method-inputs inputs + #method-output output + #method-exs exs}])))) + +(def: state-modifier^ + (Syntax StateModifier) + ($_ s;alt + (s;tag! ["" "volatile"]) + (s;tag! ["" "final"]) + (:: s;Monad<Syntax> wrap []))) + +(def: (field-decl^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax [MemberDecl FieldDecl])) + (s;either (s;form (do s;Monad<Syntax> + [_ (s;tag! ["" "const"]) + name s;local-symbol + anns (annotations^ imports) + type (generic-type^ imports type-vars) + body s;any] + (wrap [[name #PublicPM anns] (#ConstantField [type body])]))) + (s;form (do s;Monad<Syntax> + [pm privacy-modifier^ + sm state-modifier^ + name s;local-symbol + anns (annotations^ imports) + type (generic-type^ imports type-vars)] + (wrap [[name pm anns] (#VariableField [sm type])]))))) + +(def: (arg-decl^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax ArgDecl)) + (s;record (s;seq s;local-symbol + (generic-type^ imports type-vars)))) + +(def: (arg-decls^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax (List ArgDecl))) + (s;some (arg-decl^ imports type-vars))) + +(def: (constructor-arg^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax ConstructorArg)) + (s;tuple (s;seq (generic-type^ imports type-vars) s;any))) + +(def: (constructor-args^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax (List ConstructorArg))) + (s;tuple (s;some (constructor-arg^ imports type-vars)))) + +(def: (constructor-method^ imports class-vars) + (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad<Syntax> + [pm privacy-modifier^ + strict-fp? (s;tag? ["" "strict"]) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars (List/append class-vars method-vars)] + [_ arg-decls] (s;form (s;seq (s;symbol! ["" "new"]) + (arg-decls^ imports total-vars))) + constructor-args (constructor-args^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports) + body s;any] + (wrap [{#member-name constructor-method-name + #member-privacy pm + #member-anns annotations} + (#ConstructorMethod strict-fp? method-vars arg-decls constructor-args body exs)])))) + +(def: (virtual-method-def^ imports class-vars) + (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad<Syntax> + [pm privacy-modifier^ + strict-fp? (s;tag? ["" "strict"]) + final? (s;tag? ["" "final"]) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars (List/append class-vars method-vars)] + [name arg-decls] (s;form (s;seq s;local-symbol + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports) + body s;any] + (wrap [{#member-name name + #member-privacy pm + #member-anns annotations} + (#VirtualMethod final? strict-fp? method-vars arg-decls return-type body exs)])))) + +(def: (overriden-method-def^ imports) + (-> ClassImports (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad<Syntax> + [strict-fp? (s;tag? ["" "strict"]) + owner-class (class-decl^ imports) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars (List/append (product;right owner-class) method-vars)] + [name arg-decls] (s;form (s;seq s;local-symbol + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports) + body s;any] + (wrap [{#member-name name + #member-privacy #PublicPM + #member-anns annotations} + (#OverridenMethod strict-fp? owner-class method-vars arg-decls return-type body exs)])))) + +(def: (static-method-def^ imports) + (-> ClassImports (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad<Syntax> + [pm privacy-modifier^ + strict-fp? (s;tag? ["" "strict"]) + _ (s;tag! ["" "static"]) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars method-vars] + [name arg-decls] (s;form (s;seq s;local-symbol + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports) + body s;any] + (wrap [{#member-name name + #member-privacy pm + #member-anns annotations} + (#StaticMethod strict-fp? method-vars arg-decls return-type body exs)])))) + +(def: (abstract-method-def^ imports) + (-> ClassImports (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad<Syntax> + [pm privacy-modifier^ + _ (s;tag! ["" "abstract"]) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars method-vars] + [name arg-decls] (s;form (s;seq s;local-symbol + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports)] + (wrap [{#member-name name + #member-privacy pm + #member-anns annotations} + (#AbstractMethod method-vars arg-decls return-type exs)])))) + +(def: (native-method-def^ imports) + (-> ClassImports (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad<Syntax> + [pm privacy-modifier^ + _ (s;tag! ["" "native"]) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars method-vars] + [name arg-decls] (s;form (s;seq s;local-symbol + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports)] + (wrap [{#member-name name + #member-privacy pm + #member-anns annotations} + (#NativeMethod method-vars arg-decls return-type exs)])))) + +(def: (method-def^ imports class-vars) + (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) + ($_ s;either + (constructor-method^ imports class-vars) + (virtual-method-def^ imports class-vars) + (overriden-method-def^ imports) + (static-method-def^ imports) + (abstract-method-def^ imports) + (native-method-def^ imports))) + +(def: partial-call^ + (Syntax PartialCall) + (s;form (s;seq s;any s;any))) + +(def: class-kind^ + (Syntax ClassKind) + (s;either (do s;Monad<Syntax> + [_ (s;tag! ["" "class"])] + (wrap #Class)) + (do s;Monad<Syntax> + [_ (s;tag! ["" "interface"])] + (wrap #Interface)) + )) + +(def: import-member-alias^ + (Syntax (Maybe Text)) + (s;opt (do s;Monad<Syntax> + [_ (s;tag! ["" "as"])] + s;local-symbol))) + +(def: (import-member-args^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax (List [Bool GenericType]))) + (s;tuple (s;some (s;seq (s;tag? ["" "?"]) (generic-type^ imports type-vars))))) + +(def: import-member-return-flags^ + (Syntax [Bool Bool Bool]) + ($_ s;seq (s;tag? ["" "io"]) (s;tag? ["" "try"]) (s;tag? ["" "?"]))) + +(def: primitive-mode^ + (Syntax Primitive-Mode) + (s;alt (s;tag! ["" "manual"]) + (s;tag! ["" "auto"]))) + +(def: (import-member-decl^ imports owner-vars) + (-> ClassImports (List TypeParam) (Syntax ImportMemberDecl)) + ($_ s;either + (s;form (do s;Monad<Syntax> + [_ (s;tag! ["" "enum"]) + enum-members (s;some s;local-symbol)] + (wrap (#EnumDecl enum-members)))) + (s;form (do s;Monad<Syntax> + [tvars (s;default (list) (type-params^ imports)) + _ (s;symbol! ["" "new"]) + ?alias import-member-alias^ + #let [total-vars (List/append owner-vars tvars)] + ?prim-mode (s;opt primitive-mode^) + args (import-member-args^ imports total-vars) + [io? try? maybe?] import-member-return-flags^] + (wrap (#ConstructorDecl [{#import-member-mode (default #AutoPrM ?prim-mode) + #import-member-alias (default "new" ?alias) + #import-member-kind #VirtualIMK + #import-member-tvars tvars + #import-member-args args + #import-member-maybe? maybe? + #import-member-try? try? + #import-member-io? io?} + {}])) + )) + (s;form (do s;Monad<Syntax> + [kind (: (Syntax ImportMethodKind) + (s;alt (s;tag! ["" "static"]) + (wrap []))) + tvars (s;default (list) (type-params^ imports)) + name s;local-symbol + ?alias import-member-alias^ + #let [total-vars (List/append owner-vars tvars)] + ?prim-mode (s;opt primitive-mode^) + args (import-member-args^ imports total-vars) + [io? try? maybe?] import-member-return-flags^ + return (generic-type^ imports total-vars)] + (wrap (#MethodDecl [{#import-member-mode (default #AutoPrM ?prim-mode) + #import-member-alias (default name ?alias) + #import-member-kind kind + #import-member-tvars tvars + #import-member-args args + #import-member-maybe? maybe? + #import-member-try? try? + #import-member-io? io?} + {#import-method-name name + #import-method-return return + }])))) + (s;form (do s;Monad<Syntax> + [static? (s;tag? ["" "static"]) + name s;local-symbol + ?prim-mode (s;opt primitive-mode^) + gtype (generic-type^ imports owner-vars) + maybe? (s;tag? ["" "?"]) + setter? (s;tag? ["" "!"])] + (wrap (#FieldAccessDecl {#import-field-mode (default #AutoPrM ?prim-mode) + #import-field-name name + #import-field-static? static? + #import-field-maybe? maybe? + #import-field-setter? setter? + #import-field-type gtype})))) + )) + +## Generators +(def: with-parens + (-> Code Code) + (text;enclose ["(" ")"])) + +(def: with-brackets + (-> Code Code) + (text;enclose ["[" "]"])) + +(def: spaced + (-> (List Code) Code) + (text;join-with " ")) + +(def: (privacy-modifier$ pm) + (-> PrivacyModifier Code) + (case pm + #PublicPM "public" + #PrivatePM "private" + #ProtectedPM "protected" + #DefaultPM "default")) + +(def: (inheritance-modifier$ im) + (-> InheritanceModifier Code) + (case im + #FinalIM "final" + #AbstractIM "abstract" + #DefaultIM "default")) + +(def: (annotation-param$ [name value]) + (-> AnnotationParam Code) + (format name "=" (ast;ast-to-text value))) + +(def: (annotation$ [name params]) + (-> Annotation Code) + (format "(" name " " "{" (text;join-with "\t" (map annotation-param$ params)) "}" ")")) + +(def: (bound-kind$ kind) + (-> BoundKind Code) + (case kind + #UpperBound "<" + #LowerBound ">")) + +(def: (generic-type$ gtype) + (-> GenericType Code) + (case gtype + (#GenericTypeVar name) + name + + (#GenericClass name params) + (format "(" name " " (spaced (map generic-type$ params)) ")") + + (#GenericArray param) + (format "(" array-type-name " " (generic-type$ param) ")") + + (#GenericWildcard #;None) + "?" + + (#GenericWildcard (#;Some [bound-kind bound])) + (format (bound-kind$ bound-kind) (generic-type$ bound)))) + +(def: (type-param$ [name bounds]) + (-> TypeParam Code) + (format "(" name " " (spaced (map generic-type$ bounds)) ")")) + +(def: (class-decl$ (^open)) + (-> ClassDecl Code) + (format "(" class-name " " (spaced (map type-param$ class-params)) ")")) + +(def: (super-class-decl$ (^slots [#super-class-name #super-class-params])) + (-> SuperClassDecl Code) + (format "(" super-class-name " " (spaced (map generic-type$ super-class-params)) ")")) + +(def: (method-decl$ [[name pm anns] method-decl]) + (-> [MemberDecl MethodDecl] Code) + (let [(^slots [#method-tvars #method-inputs #method-output #method-exs]) method-decl] + (with-parens + (spaced (list name + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ method-tvars))) + (with-brackets (spaced (map generic-type$ method-exs))) + (with-brackets (spaced (map generic-type$ method-inputs))) + (generic-type$ method-output)) + )))) + +(def: (state-modifier$ sm) + (-> StateModifier Code) + (case sm + #VolatileSM "volatile" + #FinalSM "final" + #DefaultSM "default")) + +(def: (field-decl$ [[name pm anns] field]) + (-> [MemberDecl FieldDecl] Code) + (case field + (#ConstantField class value) + (with-parens + (spaced (list "constant" name + (with-brackets (spaced (map annotation$ anns))) + (generic-type$ class) + (ast;ast-to-text value)) + )) + + (#VariableField sm class) + (with-parens + (spaced (list "variable" name + (privacy-modifier$ pm) + (state-modifier$ sm) + (with-brackets (spaced (map annotation$ anns))) + (generic-type$ class)) + )) + )) + +(def: (arg-decl$ [name type]) + (-> ArgDecl Code) + (with-parens + (spaced (list name (generic-type$ type))))) + +(def: (constructor-arg$ [class term]) + (-> ConstructorArg Code) + (with-brackets + (spaced (list (generic-type$ class) (ast;ast-to-text term))))) + +(def: (method-def$ replacer super-class [[name pm anns] method-def]) + (-> (-> AST AST) SuperClassDecl [MemberDecl MethodDef] Code) + (case method-def + (#ConstructorMethod strict-fp? type-vars arg-decls constructor-args body exs) + (with-parens + (spaced (list "init" + (privacy-modifier$ pm) + (Bool/encode strict-fp?) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (with-brackets (spaced (map constructor-arg$ constructor-args))) + (ast;ast-to-text (pre-walk-replace replacer body)) + ))) + + (#VirtualMethod final? strict-fp? type-vars arg-decls return-type body exs) + (with-parens + (spaced (list "virtual" + name + (privacy-modifier$ pm) + (Bool/encode final?) + (Bool/encode strict-fp?) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (generic-type$ return-type) + (ast;ast-to-text (pre-walk-replace replacer body))))) + + (#OverridenMethod strict-fp? class-decl type-vars arg-decls return-type body exs) + (let [super-replacer (parser->replacer (s;form (do s;Monad<Syntax> + [_ (s;symbol! ["" ".super!"]) + args (s;tuple (s;exactly (list;size arg-decls) s;any)) + #let [arg-decls' (: (List Text) (map (. (simple-class$ (list)) product;right) + arg-decls))]] + (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format "invokespecial" ":" (get@ #super-class-name super-class) ":" name ":" (text;join-with "," arg-decls'))))] + [(~' _jvm_this) (~@ args)]))))))] + (with-parens + (spaced (list "override" + (class-decl$ class-decl) + name + (Bool/encode strict-fp?) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (generic-type$ return-type) + (|> body + (pre-walk-replace replacer) + (pre-walk-replace super-replacer) + (ast;ast-to-text)) + )))) + + (#StaticMethod strict-fp? type-vars arg-decls return-type body exs) + (with-parens + (spaced (list "static" + name + (privacy-modifier$ pm) + (Bool/encode strict-fp?) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (generic-type$ return-type) + (ast;ast-to-text (pre-walk-replace replacer body))))) + + (#AbstractMethod type-vars arg-decls return-type exs) + (with-parens + (spaced (list "abstract" + name + (privacy-modifier$ pm) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (generic-type$ return-type)))) + + (#NativeMethod type-vars arg-decls return-type exs) + (with-parens + (spaced (list "native" + name + (privacy-modifier$ pm) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (generic-type$ return-type)))) + )) + +(def: (complete-call$ obj [method args]) + (-> AST PartialCall AST) + (` ((~ method) (~ args) (~ obj)))) + +## [Syntax] +(def: object-super-class + SuperClassDecl + {#super-class-name "java.lang.Object" + #super-class-params (list)}) + +(syntax: #export (class: {#let [imports (class-imports *compiler*)]} + {im inheritance-modifier^} + {class-decl (class-decl^ imports)} + {#let [full-class-name (product;left class-decl) + imports (add-import [(short-class-name full-class-name) full-class-name] + (class-imports *compiler*))]} + {#let [class-vars (product;right class-decl)]} + {super (s;opt (super-class-decl^ imports class-vars))} + {interfaces (s;tuple (s;some (super-class-decl^ imports class-vars)))} + {annotations (annotations^ imports)} + {fields (s;some (field-decl^ imports class-vars))} + {methods (s;some (method-def^ imports class-vars))}) + {#;doc (doc "Allows defining JVM classes in Lux code." + "For example:" + (class: #final (JvmPromise A) [] + ## Fields + (#private resolved boolean) + (#private datum A) + (#private waitingList (java.util.List lux.Function)) + ## Methods + (#public new [] [] [] + (exec (:= .resolved false) + (:= .waitingList (ArrayList.new [])) + [])) + (#public resolve [] [{value A}] boolean + (let [container (.new! [])] + (synchronized _jvm_this + (if .resolved + false + (exec (:= .datum value) + (:= .resolved true) + (let [sleepers .waitingList + sleepers-count (java.util.List.size [] sleepers)] + (map (lambda [idx] + (let [sleeper (java.util.List.get [(l2i idx)] sleepers)] + (Executor.execute [(@runnable (lux.Function.apply [(:! Object value)] sleeper))] + executor))) + (range 0 (dec (i2l sleepers-count))))) + (:= .waitingList (null)) + true))))) + (#public poll [] [] A + .datum) + (#public wasResolved [] [] boolean + (synchronized _jvm_this + .resolved)) + (#public waitOn [] [{callback lux.Function}] void + (synchronized _jvm_this + (exec (if .resolved + (lux.Function.apply [(:! Object .datum)] callback) + (:! Object (java.util.List.add [callback] .waitingList))) + []))) + (#public #static make [A] [{value A}] (lux.concurrency.promise.JvmPromise A) + (let [container (.new! [])] + (exec (.resolve! (:! (host lux.concurrency.promise.JvmPromise [Unit]) container) [(:! Unit value)]) + container)))) + + "The vector corresponds to parent interfaces." + "An optional super-class can be specified before the vector. If not specified, java.lang.Object will be assumed." + "Fields and methods defined in the class can be used with special syntax." + "For example:" + ".resolved, for accessing the \"resolved\" field." + "(:= .resolved true) for modifying it." + "(.new! []) for calling the class's constructor." + "(.resolve! container [value]) for calling the \"resolve\" method." + )} + (do Monad<Lux> + [current-module compiler;current-module-name + #let [fully-qualified-class-name (format (text;replace "/" "." current-module) "." full-class-name) + field-parsers (map (field->parser fully-qualified-class-name) fields) + method-parsers (map (method->parser (product;right class-decl) fully-qualified-class-name) methods) + replacer (parser->replacer (fold s;either + (s;fail "") + (List/append field-parsers method-parsers))) + super-class (default object-super-class super) + def-code (format "class:" + (spaced (list (class-decl$ class-decl) + (super-class-decl$ super-class) + (with-brackets (spaced (map super-class-decl$ interfaces))) + (inheritance-modifier$ im) + (with-brackets (spaced (map annotation$ annotations))) + (with-brackets (spaced (map field-decl$ fields))) + (with-brackets (spaced (map (method-def$ replacer super-class) methods))))))]] + (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))))) + +(syntax: #export (interface: {#let [imports (class-imports *compiler*)]} + {class-decl (class-decl^ imports)} + {#let [full-class-name (product;left class-decl) + imports (add-import [(short-class-name full-class-name) full-class-name] + (class-imports *compiler*))]} + {#let [class-vars (product;right class-decl)]} + {supers (s;tuple (s;some (super-class-decl^ imports class-vars)))} + {annotations (annotations^ imports)} + {members (s;some (method-decl^ imports class-vars))}) + (let [def-code (format "interface:" + (spaced (list (class-decl$ class-decl) + (with-brackets (spaced (map super-class-decl$ supers))) + (with-brackets (spaced (map annotation$ annotations))) + (spaced (map method-decl$ members)))))] + (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))) + )) + +(syntax: #export (object {#let [imports (class-imports *compiler*)]} + {#let [class-vars (list)]} + {super (s;opt (super-class-decl^ imports class-vars))} + {interfaces (s;tuple (s;some (super-class-decl^ imports class-vars)))} + {constructor-args (constructor-args^ imports class-vars)} + {methods (s;some (overriden-method-def^ imports))}) + {#;doc (doc "Allows defining anonymous classes." + "The 1st vector corresponds to parent interfaces." + "The 2nd vector corresponds to arguments to the super class constructor." + "An optional super-class can be specified before the 1st vector. If not specified, java.lang.Object will be assumed." + (object [java.lang.Runnable] + [] + (java.lang.Runnable run [] [] void + (exec (do-something some-input) + []))) + )} + (let [super-class (default object-super-class super) + def-code (format "anon-class:" + (spaced (list (super-class-decl$ super-class) + (with-brackets (spaced (map super-class-decl$ interfaces))) + (with-brackets (spaced (map constructor-arg$ constructor-args))) + (with-brackets (spaced (map (method-def$ id super-class) methods))))))] + (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))))) + +(syntax: #export (null) + {#;doc (doc "Null object pointer." + (null))} + (wrap (list (` (;_lux_proc ["jvm" "null"] []))))) + +(def: #export (null? obj) + {#;doc (doc "Test for null object pointer." + (null? (null)) + "=>" + true + (null? "YOLO") + "=>" + false)} + (-> (host java.lang.Object) Bool) + (;_lux_proc ["jvm" "null?"] [obj])) + +(syntax: #export (??? expr) + {#;doc (doc "Takes a (potentially null) object pointer and creates a (Maybe ObjectType) for it." + (??? (: java.lang.Thread (null))) + "=>" + #;None + (??? "YOLO") + "=>" + (#;Some "YOLO"))} + (with-gensyms [g!temp] + (wrap (list (` (let [(~ g!temp) (~ expr)] + (if (;_lux_proc ["jvm" "null?"] [(~ g!temp)]) + #;None + (#;Some (~ g!temp))))))))) + +(syntax: #export (!!! expr) + {#;doc (doc "Takes a (Maybe ObjectType) and return a ObjectType." + "A #;None would gets translated in to a (null)." + "Takes a (potentially null) object pointer and creates a (Maybe ObjectType) for it." + (!!! (??? (: java.lang.Thread (null)))) + "=>" + (null) + (!!! (??? "YOLO")) + "=>" + "YOLO")} + (with-gensyms [g!value] + (wrap (list (` (;_lux_case (~ expr) + (#;Some (~ g!value)) + (~ g!value) + + #;None + (;_lux_proc ["jvm" "null"] []))))))) + +(syntax: #export (try expr) + {#;doc (doc "Covers the expression in a try-catch block." + "If it succeeds, you get (#;Right result)." + "If it fails, you get (#;Left error+stack-traces-as-text)." + (try (risky-computation input)))} + (wrap (list (`' (_lux_proc ["jvm" "try"] + [(#;Right (~ expr)) + ;;throwable->text]))))) + +(syntax: #export (instance? {#let [imports (class-imports *compiler*)]} + {class (generic-type^ imports (list))} + obj) + {#;doc (doc "Checks whether an object is an instance of a particular class." + "Caveat emptor: Can't check for polymorphism, so avoid using parameterized classes." + (instance? String "YOLO"))} + (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text (format "instanceof" ":" (simple-class$ (list) class))))] [(~ obj)]))))) + +(syntax: #export (synchronized lock body) + {#;doc (doc "Evaluates body, while holding a lock on a given object." + (synchronized object-to-be-locked + (exec (do-something ...) + (do-something-else ...) + (finish-the-computation ...))))} + (wrap (list (` (;_lux_proc ["jvm" "synchronized"] [(~ lock) (~ body)])))) + ## (with-gensyms [g!lock g!body g!_ g!e] + ## (wrap (list (` (let [(~ g!lock) (~ lock) + ## (~ g!_) (;_lux_proc ["jvm" "monitorenter"] [(~ g!lock)]) + ## (~ g!body) (~ body) + ## (~ g!_) (;_lux_proc ["jvm" "monitorexit"] [(~ g!lock)])] + ## (~ g!body))))) + ## ) + ) + +(syntax: #export (do-to obj {methods (s;some partial-call^)}) + {#;doc (doc "Call a variety of methods on an object; then return the object." + (do-to vreq + (HttpServerRequest.setExpectMultipart [true]) + (ReadStream.handler [(object [(Handler Buffer)] + [] + ((Handler A) handle [] [(buffer A)] void + (io;run (do Monad<IO> + [_ (write (Buffer.getBytes [] buffer) body)] + (wrap [])))) + )]) + (ReadStream.endHandler [[(object [(Handler Void)] + [] + ((Handler A) handle [] [(_ A)] void + (exec (do Monad<Promise> + [#let [_ (io;run (close body))] + response (handler (request$ vreq body))] + (respond! response vreq)) + [])) + )]])))} + (with-gensyms [g!obj] + (wrap (list (` (let [(~ g!obj) (~ obj)] + (exec (~@ (map (complete-call$ g!obj) methods)) + (~ g!obj)))))))) + +(def: (class-import$ long-name? [full-name params]) + (-> Bool ClassDecl AST) + (let [def-name (if long-name? + full-name + (short-class-name full-name))] + (case params + #;Nil + (` (def: (~ (ast;symbol ["" def-name])) + {#;type? true + #;;jvm-class (~ (ast;text full-name))} + Type + (host (~ (ast;symbol ["" full-name]))))) + + (#;Cons _) + (let [params' (map (lambda [[p _]] (ast;symbol ["" p])) params)] + (` (def: (~ (ast;symbol ["" def-name])) + {#;type? true + #;;jvm-class (~ (ast;text full-name))} + Type + (All [(~@ params')] + (host (~ (ast;symbol ["" full-name])) + [(~@ params')])))))))) + +(def: (member-type-vars class-tvars member) + (-> (List TypeParam) ImportMemberDecl (List TypeParam)) + (case member + (#ConstructorDecl [commons _]) + (List/append class-tvars (get@ #import-member-tvars commons)) + + (#MethodDecl [commons _]) + (case (get@ #import-member-kind commons) + #StaticIMK + (get@ #import-member-tvars commons) + + _ + (List/append class-tvars (get@ #import-member-tvars commons))) + + _ + class-tvars)) + +(def: (member-def-arg-bindings type-params class member) + (-> (List TypeParam) ClassDecl ImportMemberDecl (Lux [(List AST) (List AST) (List Text) (List AST)])) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (let [(^slots [#import-member-tvars #import-member-args]) commons] + (do Monad<Lux> + [arg-inputs (mapM @ + (: (-> [Bool GenericType] (Lux [AST AST])) + (lambda [[maybe? _]] + (with-gensyms [arg-name] + (wrap [arg-name (if maybe? + (` (!!! (~ arg-name))) + arg-name)])))) + import-member-args) + #let [arg-classes (: (List Text) + (map (. (simple-class$ (List/append type-params import-member-tvars)) product;right) + import-member-args)) + arg-types (map (: (-> [Bool GenericType] AST) + (lambda [[maybe? arg]] + (let [arg-type (class->type (get@ #import-member-mode commons) type-params arg)] + (if maybe? + (` (Maybe (~ arg-type))) + arg-type)))) + import-member-args) + arg-lambda-inputs (map product;left arg-inputs) + arg-method-inputs (map product;right arg-inputs)]] + (wrap [arg-lambda-inputs arg-method-inputs arg-classes arg-types]))) + + _ + (:: Monad<Lux> wrap [(list) (list) (list) (list)]))) + +(def: (member-def-return mode type-params class member) + (-> Primitive-Mode (List TypeParam) ClassDecl ImportMemberDecl (Lux AST)) + (case member + (#ConstructorDecl _) + (:: Monad<Lux> wrap (class-decl-type$ class)) + + (#MethodDecl [_ method]) + (:: Monad<Lux> wrap (class->type mode type-params (get@ #import-method-return method))) + + _ + (compiler;fail "Only methods have return values."))) + +(def: (decorate-return-maybe member [return-type return-term]) + (-> ImportMemberDecl [AST AST] [AST AST]) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (if (get@ #import-member-maybe? commons) + [(` (Maybe (~ return-type))) + (` (??? (~ return-term)))] + [return-type + (let [g!temp (ast;symbol ["" "Ω"])] + (` (let [(~ g!temp) (~ return-term)] + (if (null? (:! (host (~' java.lang.Object)) + (~ g!temp))) + (error! "Can't produce null pointers from method calls.") + (~ g!temp)))))]) + + _ + [return-type return-term])) + +(do-template [<name> <tag> <type-trans> <term-trans>] + [(def: (<name> member [return-type return-term]) + (-> ImportMemberDecl [AST AST] [AST AST]) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (if (get@ <tag> commons) + [<type-trans> <term-trans>] + [return-type return-term]) + + _ + [return-type return-term]))] + + [decorate-return-try #import-member-try? (` (Either Text (~ return-type))) (` (try (~ return-term)))] + [decorate-return-io #import-member-io? (` (IO (~ return-type))) (` (io (~ return-term)))] + ) + +(def: (free-type-param? [name bounds]) + (-> TypeParam Bool) + (case bounds + #;Nil true + _ false)) + +(def: (type-param->type-arg [name _]) + (-> TypeParam AST) + (ast;symbol ["" name])) + +(def: (with-mode-output mode output-type body) + (-> Primitive-Mode GenericType AST AST) + (case mode + #ManualPrM + body + + #AutoPrM + (case output-type + (#GenericClass ["byte" _]) + (` (b2l (~ body))) + + (#GenericClass ["short" _]) + (` (s2l (~ body))) + + (#GenericClass ["int" _]) + (` (i2l (~ body))) + + (#GenericClass ["float" _]) + (` (f2d (~ body))) + + _ + body))) + +(def: (auto-conv-class? class) + (-> Text Bool) + (case class + (^or "byte" "short" "int" "float") + true + + _ + false)) + +(def: (auto-conv [class var]) + (-> [Text AST] (List AST)) + (case class + "byte" (list var (` (l2b (~ var)))) + "short" (list var (` (l2s (~ var)))) + "int" (list var (` (l2i (~ var)))) + "float" (list var (` (d2f (~ var)))) + _ (list))) + +(def: (with-mode-inputs mode inputs body) + (-> Primitive-Mode (List [Text AST]) AST AST) + (case mode + #ManualPrM + body + + #AutoPrM + (` (let [(~@ (|> inputs + (List/map auto-conv) + List/join))] + (~ body))))) + +(def: (with-mode-field-get mode class output) + (-> Primitive-Mode GenericType AST AST) + (case mode + #ManualPrM + output + + #AutoPrM + (case (simple-class$ (list) class) + "byte" (` (b2l (~ output))) + "short" (` (s2l (~ output))) + "int" (` (i2l (~ output))) + "float" (` (f2d (~ output))) + _ output))) + +(def: (with-mode-field-set mode class input) + (-> Primitive-Mode GenericType AST AST) + (case mode + #ManualPrM + input + + #AutoPrM + (case (simple-class$ (list) class) + "byte" (` (l2b (~ input))) + "short" (` (l2s (~ input))) + "int" (` (l2i (~ input))) + "float" (` (d2f (~ input))) + _ input))) + +(def: (member-def-interop type-params kind class [arg-lambda-inputs arg-method-inputs arg-classes arg-types] member method-prefix) + (-> (List TypeParam) ClassKind ClassDecl [(List AST) (List AST) (List Text) (List AST)] ImportMemberDecl Text (Lux (List AST))) + (let [[full-name class-tvars] class + all-params (|> (member-type-vars class-tvars member) + (filter free-type-param?) + (map type-param->type-arg))] + (case member + (#EnumDecl enum-members) + (do Monad<Lux> + [#let [enum-type (: AST + (case class-tvars + #;Nil + (` (host (~ (ast;symbol ["" full-name])))) + + _ + (let [=class-tvars (|> class-tvars + (filter free-type-param?) + (map type-param->type-arg))] + (` (All [(~@ =class-tvars)] (host (~ (ast;symbol ["" full-name])) [(~@ =class-tvars)])))))) + getter-interop (: (-> Text AST) + (lambda [name] + (let [getter-name (ast;symbol ["" (format method-prefix member-separator name)])] + (` (def: (~ getter-name) + (~ enum-type) + (;_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" full-name ":" name)))] []))))))]] + (wrap (map getter-interop enum-members))) + + (#ConstructorDecl [commons _]) + (do Monad<Lux> + [return-type (member-def-return (get@ #import-member-mode commons) type-params class member) + #let [def-name (ast;symbol ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) + def-params (list (ast;tuple arg-lambda-inputs)) + jvm-interop (|> (` (;_lux_proc ["jvm" (~ (ast;text (format "new" ":" full-name ":" (text;join-with "," arg-classes))))] + [(~@ arg-method-inputs)])) + (with-mode-inputs (get@ #import-member-mode commons) + (list;zip2 arg-classes arg-lambda-inputs))) + [return-type jvm-interop] (|> [return-type jvm-interop] + (decorate-return-maybe member) + (decorate-return-try member) + (decorate-return-io member))]] + (wrap (list (` (def: ((~ def-name) (~@ def-params)) + (All [(~@ all-params)] (-> [(~@ arg-types)] (~ return-type))) + (~ jvm-interop)))))) + + (#MethodDecl [commons method]) + (with-gensyms [g!obj] + (do @ + [return-type (member-def-return (get@ #import-member-mode commons) type-params class member) + #let [def-name (ast;symbol ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) + (^slots [#import-member-kind]) commons + (^slots [#import-method-name]) method + [jvm-op obj-ast class-ast] (: [Text (List AST) (List AST)] + (case import-member-kind + #StaticIMK + ["invokestatic" + (list) + (list)] + + #VirtualIMK + (case kind + #Class + ["invokevirtual" + (list g!obj) + (list (class-decl-type$ class))] + + #Interface + ["invokeinterface" + (list g!obj) + (list (class-decl-type$ class))] + ))) + def-params (#;Cons (ast;tuple arg-lambda-inputs) obj-ast) + def-param-types (#;Cons (` [(~@ arg-types)]) class-ast) + jvm-interop (|> (` (;_lux_proc ["jvm" (~ (ast;text (format jvm-op ":" full-name ":" import-method-name + ":" (text;join-with "," arg-classes))))] + [(~@ obj-ast) (~@ arg-method-inputs)])) + (with-mode-output (get@ #import-member-mode commons) + (get@ #import-method-return method)) + (with-mode-inputs (get@ #import-member-mode commons) + (list;zip2 arg-classes arg-lambda-inputs))) + [return-type jvm-interop] (|> [return-type jvm-interop] + (decorate-return-maybe member) + (decorate-return-try member) + (decorate-return-io member))]] + (wrap (list (` (def: ((~ def-name) (~@ def-params)) + (All [(~@ all-params)] (-> (~@ def-param-types) (~ return-type))) + (~ jvm-interop))))))) + + (#FieldAccessDecl fad) + (do Monad<Lux> + [#let [(^open) fad + base-gtype (class->type import-field-mode type-params import-field-type) + g!class (class-decl-type$ class) + g!type (if import-field-maybe? + (` (Maybe (~ base-gtype))) + base-gtype) + tvar-asts (: (List AST) + (|> class-tvars + (filter free-type-param?) + (map type-param->type-arg))) + getter-name (ast;symbol ["" (format method-prefix member-separator import-field-name)]) + setter-name (ast;symbol ["" (format method-prefix member-separator import-field-name "!")])] + getter-interop (with-gensyms [g!obj] + (let [getter-call (if import-field-static? + getter-name + (` ((~ getter-name) (~ g!obj)))) + getter-type (if import-field-setter? + (` (IO (~ g!type))) + g!type) + getter-type (if import-field-static? + getter-type + (` (-> (~ g!class) (~ getter-type)))) + getter-type (` (All [(~@ tvar-asts)] (~ getter-type))) + getter-body (if import-field-static? + (with-mode-field-get import-field-mode import-field-type + (` (;_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" full-name ":" import-field-name)))] []))) + (with-mode-field-get import-field-mode import-field-type + (` (;_lux_proc ["jvm" (~ (ast;text (format "getfield" ":" full-name ":" import-field-name)))] [(~ g!obj)])))) + getter-body (if import-field-maybe? + (` (??? (~ getter-body))) + getter-body) + getter-body (if import-field-setter? + (` (io (~ getter-body))) + getter-body)] + (wrap (` (def: (~ getter-call) + (~ getter-type) + (~ getter-body)))))) + setter-interop (if import-field-setter? + (with-gensyms [g!obj g!value] + (let [setter-call (if import-field-static? + (` ((~ setter-name) (~ g!value))) + (` ((~ setter-name) (~ g!value) (~ g!obj)))) + setter-type (if import-field-static? + (` (All [(~@ tvar-asts)] (-> (~ g!type) (IO Unit)))) + (` (All [(~@ tvar-asts)] (-> (~ g!type) (~ g!class) (IO Unit))))) + setter-value (with-mode-field-set import-field-mode import-field-type g!value) + setter-value (if import-field-maybe? + (` (!!! (~ setter-value))) + setter-value) + setter-command (format (if import-field-static? "putstatic" "putfield") + ":" full-name ":" import-field-name)] + (wrap (: (List AST) + (list (` (def: (~ setter-call) + (~ setter-type) + (io (;_lux_proc ["jvm" (~ (ast;text setter-command))] + [(~ setter-value)]))))))))) + (wrap (list)))] + (wrap (list& getter-interop setter-interop))) + ))) + +(def: (member-import$ type-params long-name? kind class member) + (-> (List TypeParam) Bool ClassKind ClassDecl ImportMemberDecl (Lux (List AST))) + (let [[full-name _] class + method-prefix (if long-name? + full-name + (short-class-name full-name))] + (do Monad<Lux> + [=args (member-def-arg-bindings type-params class member)] + (member-def-interop type-params kind class =args member method-prefix)))) + +(def: (interface? class) + (All [a] (-> (host java.lang.Class [a]) Bool)) + (_lux_proc ["jvm" "invokevirtual:java.lang.Class:isInterface:"] [class])) + +(def: (load-class class-name) + (-> Text (Either Text (host java.lang.Class [(Ex [a] a)]))) + (try (_lux_proc ["jvm" "invokestatic:java.lang.Class:forName:java.lang.String"] [class-name]))) + +(def: (class-kind [class-name _]) + (-> ClassDecl (Lux ClassKind)) + (case (load-class class-name) + (#;Right class) + (:: Monad<Lux> wrap (if (interface? class) + #Interface + #Class)) + + (#;Left _) + (compiler;fail (format "Unknown class: " class-name)))) + +(syntax: #export (jvm-import {#let [imports (class-imports *compiler*)]} + {long-name? (s;tag? ["" "long"])} + {class-decl (class-decl^ imports)} + {#let [full-class-name (product;left class-decl) + imports (add-import [(short-class-name full-class-name) full-class-name] + (class-imports *compiler*))]} + {members (s;some (import-member-decl^ imports (product;right class-decl)))}) + {#;doc (doc "Allows importing JVM classes, and using them as types." + "Their methods, fields and enum options can also be imported." + "Also, classes which get imported into a module can also be referred-to with their short names in other macros that require JVM classes." + "Examples:" + (jvm-import java.lang.Object + (new [] []) + (equals [] [Object] boolean) + (wait [] [int] #io #try void)) + "Special options can also be given for the return values." + "#? means that the values will be returned inside a Maybe type. That way, null becomes #;None." + "#try means that the computation might throw an exception, and the return value will be wrapped by the Error type." + "#io means the computation has side effects, and will be wrapped by the IO type." + "These options must show up in the following order [#io #try #?] (although, each option can be used independently)." + (jvm-import java.lang.String + (new [] [(Array byte)]) + (#static valueOf [] [char] String) + (#static valueOf #as int-valueOf [] [int] String)) + + (jvm-import #long (java.util.List e) + (size [] [] int) + (get [] [int] e)) + + (jvm-import (java.util.ArrayList a) + (toArray [T] [(Array T)] (Array T))) + "#long makes it so the class-type that is generated is of the fully-qualified name." + "In this case, it avoids a clash between the java.util.List type, and Lux's own List type." + (jvm-import java.lang.Character$UnicodeScript + (#enum ARABIC CYRILLIC LATIN)) + "All enum options to be imported must be specified." + + (jvm-import #long (lux.concurrency.promise.JvmPromise A) + (resolve [] [A] boolean) + (poll [] [] A) + (wasResolved [] [] boolean) + (waitOn [] [lux.Function] void) + (#static make [A] [A] (JvmPromise A))) + "It should also be noted, the only types that may show up in method arguments or return values may be Java classes, arrays, primitives, void or type-parameters." + "Lux types, such as Maybe can't be named (otherwise, they'd be confused for Java classes)." + + "Also, the names of the imported members will look like ClassName.MemberName." + "E.g.:" + (Object.new []) + (Object.equals [other-object] my-object) + (java.util.List.size [] my-list) + Character$UnicodeScript.LATIN + )} + (do Monad<Lux> + [kind (class-kind class-decl) + =members (mapM @ (member-import$ (product;right class-decl) long-name? kind class-decl) members)] + (wrap (list& (class-import$ long-name? class-decl) (List/join =members))))) + +(syntax: #export (array {#let [imports (class-imports *compiler*)]} + {type (generic-type^ imports (list))} + size) + {#;doc (doc "Create an array of the given type, with the given size." + (array Object +10))} + (case type + (^template [<type> <array-op>] + (^ (#GenericClass <type> (list))) + (wrap (list (` (;_lux_proc ["jvm" <array-op>] [(~ size)]))))) + (["boolean" "znewarray"] + ["byte" "bnewarray"] + ["short" "snewarray"] + ["int" "inewarray"] + ["long" "lnewarray"] + ["float" "fnewarray"] + ["double" "dnewarray"] + ["char" "cnewarray"]) + + _ + (wrap (list (` (;_lux_proc ["jvm" "anewarray"] [(~ (ast;text (generic-type$ type))) (~ size)])))))) + +(syntax: #export (array-length array) + {#;doc (doc "Gives the length of an array." + (array-length my-array))} + (wrap (list (` (;_lux_proc ["jvm" "arraylength"] [(~ array)]))))) + +(def: (type->class-name type) + (-> Type (Lux Text)) + (case type + (#;HostT name params) + (:: Monad<Lux> wrap name) + + (#;AppT F A) + (case (type;apply-type F A) + #;None + (compiler;fail (format "Can't apply type: " (type;type-to-text F) " to " (type;type-to-text A))) + + (#;Some type') + (type->class-name type')) + + (#;NamedT _ type') + (type->class-name type') + + #;UnitT + (:: Monad<Lux> wrap "java.lang.Object") + + (^or #;VoidT (#;VarT _) (#;ExT _) (#;BoundT _) (#;SumT _) (#;ProdT _) (#;LambdaT _) (#;UnivQ _) (#;ExQ _)) + (compiler;fail (format "Can't convert to JvmType: " (type;type-to-text type))) + )) + +(syntax: #export (array-load idx array) + {#;doc (doc "Loads an element from an array." + (array-load 10 my-array))} + (case array + [_ (#;SymbolS array-name)] + (do Monad<Lux> + [array-type (compiler;find-type array-name) + array-jvm-type (type->class-name array-type)] + (case array-jvm-type + (^template [<type> <array-op>] + <type> + (wrap (list (` (;_lux_proc ["jvm" <array-op>] [(~ array) (~ idx)]))))) + (["[Z" "zaload"] + ["[B" "baload"] + ["[S" "saload"] + ["[I" "iaload"] + ["[J" "jaload"] + ["[F" "faload"] + ["[D" "daload"] + ["[C" "caload"]) + + _ + (wrap (list (` (;_lux_proc ["jvm" "aaload"] [(~ array) (~ idx)])))))) + + _ + (with-gensyms [g!array] + (wrap (list (` (let [(~ g!array) (~ array)] + (;;array-load (~ g!array) (~ idx))))))))) + +(syntax: #export (array-store idx value array) + {#;doc (doc "Stores an element into an array." + (array-store 10 my-object my-array))} + (case array + [_ (#;SymbolS array-name)] + (do Monad<Lux> + [array-type (compiler;find-type array-name) + array-jvm-type (type->class-name array-type)] + (case array-jvm-type + (^template [<type> <array-op>] + <type> + (wrap (list (` (;_lux_proc ["jvm" <array-op>] [(~ array) (~ idx) (~ value)]))))) + (["[Z" "zastore"] + ["[B" "bastore"] + ["[S" "sastore"] + ["[I" "iastore"] + ["[J" "jastore"] + ["[F" "fastore"] + ["[D" "dastore"] + ["[C" "castore"]) + + _ + (wrap (list (` (;_lux_proc ["jvm" "aastore"] [(~ array) (~ idx) (~ value)])))))) + + _ + (with-gensyms [g!array] + (wrap (list (` (let [(~ g!array) (~ array)] + (;;array-store (~ g!array) (~ idx) (~ value))))))))) + +(def: simple-bindings^ + (Syntax (List [Text AST])) + (s;tuple (s;some (s;seq s;local-symbol s;any)))) + +(syntax: #export (with-open {bindings simple-bindings^} body) + {#;doc (doc "Creates a local-binding with the desired resources, and runs the body (assumed to be in the IO type)." + "Afterwards, closes all resources (assumed to be subclasses of java.io.Closeable), and returns the value resulting from running the body." + (with-open [my-res1 (res1-constructor ...) + my-res2 (res1-constructor ...)] + (do Monad<IO> + [foo (do-something my-res1) + bar (do-something-else my-res2)] + (do-one-last-thing foo bar))))} + (with-gensyms [g!output g!_] + (let [inits (List/join (List/map (lambda [[res-name res-ctor]] + (list (ast;symbol ["" res-name]) res-ctor)) + bindings)) + closes (List/map (lambda [res] + (` (try (;_lux_proc ["jvm" "invokevirtual:java.io.Closeable:close:"] + [(~ (ast;symbol ["" (product;left res)]))])))) + bindings)] + (wrap (list (` (do Monad<IO> + [(~@ inits) + (~ g!output) (~ body) + (~' #let) [(~ g!_) (exec (~@ (reverse closes)) [])]] + ((~' wrap) (~ g!output))))))))) + +(syntax: #export (class-for {#let [imports (class-imports *compiler*)]} + {type (generic-type^ imports (list))}) + {#;doc (doc "Loads the class a a Class object." + (class-for java.lang.String))} + (wrap (list (` (;_lux_proc ["jvm" "load-class"] [(~ (ast;text (simple-class$ (list) type)))]))))) diff --git a/stdlib/source/lux/lexer.lux b/stdlib/source/lux/lexer.lux new file mode 100644 index 000000000..654259d8d --- /dev/null +++ b/stdlib/source/lux/lexer.lux @@ -0,0 +1,439 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + [lux #- not] + (lux (control functor + applicative + monad + codec) + (data [text "Text/" Eq<Text>] + text/format + [number "Int/" Codec<Text,Int>] + [product] + [char "Char/" Ord<Char>] + maybe + error + (struct [list "" Functor<List>])) + host)) + +## [Types] +(type: #export (Lexer a) + (-> Text (Error [Text a]))) + +## [Structures] +(struct: #export _ (Functor Lexer) + (def: (map f fa) + (lambda [input] + (case (fa input) + (#;Left msg) (#;Left msg) + (#;Right [input' output]) (#;Right [input' (f output)]))))) + +(struct: #export _ (Applicative Lexer) + (def: functor Functor<Lexer>) + + (def: (wrap a) + (lambda [input] + (#;Right [input a]))) + + (def: (apply ff fa) + (lambda [input] + (case (ff input) + (#;Right [input' f]) + (case (fa input') + (#;Right [input'' a]) + (#;Right [input'' (f a)]) + + (#;Left msg) + (#;Left msg)) + + (#;Left msg) + (#;Left msg))))) + +(struct: #export _ (Monad Lexer) + (def: applicative Applicative<Lexer>) + + (def: (join mma) + (lambda [input] + (case (mma input) + (#;Left msg) (#;Left msg) + (#;Right [input' ma]) (ma input')))) + ) + +## [Values] +## Runner +(def: #export (run' lexer input) + (All [a] (-> (Lexer a) Text (Error [Text a]))) + (lexer input)) + +(def: #export (run lexer input) + (All [a] (-> (Lexer a) Text (Error a))) + (case (lexer input) + (#;Left msg) + (#;Left msg) + + (#;Right [input' output]) + (#;Right output) + )) + +## Combinators +(def: #export (fail message) + (All [a] (-> Text (Lexer a))) + (lambda [input] + (#;Left message))) + +(def: #export any + (Lexer Char) + (lambda [input] + (case [(text;at +0 input) (text;split +1 input)] + [(#;Some output) (#;Some [_ input'])] + (#;Right [input' output]) + + _ + (#;Left "Can't parse character from empty text.")) + )) + +(def: #export (seq left right) + (All [a b] (-> (Lexer a) (Lexer b) (Lexer [a b]))) + (do Monad<Lexer> + [=left left + =right right] + (wrap [=left =right]))) + +(def: #export (alt left right) + (All [a b] (-> (Lexer a) (Lexer b) (Lexer (| a b)))) + (lambda [input] + (case (left input) + (#;Left msg) + (case (right input) + (#;Left msg) + (#;Left msg) + + (#;Right [input' output]) + (#;Right [input' (+1 output)])) + + (#;Right [input' output]) + (#;Right [input' (+0 output)])))) + +(def: #export (not! p) + (All [a] (-> (Lexer a) (Lexer Unit))) + (lambda [input] + (case (p input) + (#;Left msg) + (#;Right [input []]) + + _ + (#;Left "Expected to fail; yet succeeded.")))) + +(def: #export (not p) + (All [a] (-> (Lexer a) (Lexer Char))) + (lambda [input] + (case (p input) + (#;Left msg) + (any input) + + _ + (#;Left "Expected to fail; yet succeeded.")))) + +(def: #export (either left right) + (All [a] (-> (Lexer a) (Lexer a) (Lexer a))) + (lambda [input] + (case (left input) + (#;Left msg) + (right input) + + output + output))) + +(def: #export (assert test message) + (-> Bool Text (Lexer Unit)) + (lambda [input] + (if test + (#;Right [input []]) + (#;Left message)))) + +(def: #export (some p) + (All [a] (-> (Lexer a) (Lexer (List a)))) + (lambda [input] + (case (p input) + (#;Left msg) + (#;Right [input (list)]) + + (#;Right [input' x]) + (run' (do Monad<Lexer> + [xs (some p)] + (wrap (#;Cons x xs))) + input')) + )) + +(def: #export (many p) + (All [a] (-> (Lexer a) (Lexer (List a)))) + (do Monad<Lexer> + [x p + xs (some p)] + (wrap (#;Cons x xs)))) + +(def: #export (exactly n p) + (All [a] (-> Nat (Lexer a) (Lexer (List a)))) + (if (>+ +0 n) + (do Monad<Lexer> + [x p + xs (exactly (dec+ n) p)] + (wrap (#;Cons x xs))) + (:: Monad<Lexer> wrap (list)))) + +(def: #export (at-most n p) + (All [a] (-> Nat (Lexer a) (Lexer (List a)))) + (if (>+ +0 n) + (lambda [input] + (case (p input) + (#;Left msg) + (#;Right [input (list)]) + + (#;Right [input' x]) + (run' (do Monad<Lexer> + [xs (at-most (dec+ n) p)] + (wrap (#;Cons x xs))) + input') + )) + (:: Monad<Lexer> wrap (list)))) + +(def: #export (at-least n p) + (All [a] (-> Nat (Lexer a) (Lexer (List a)))) + (do Monad<Lexer> + [min-xs (exactly n p) + extras (some p)] + (wrap (list;concat (list min-xs extras))))) + +(def: #export (between from to p) + (All [a] (-> Nat Nat (Lexer a) (Lexer (List a)))) + (do Monad<Lexer> + [min-xs (exactly from p) + max-xs (at-most (-+ from to) p)] + (wrap (list;concat (list min-xs max-xs))))) + +(def: #export (opt p) + (All [a] (-> (Lexer a) (Lexer (Maybe a)))) + (lambda [input] + (case (p input) + (#;Left msg) + (#;Right [input #;None]) + + (#;Right [input value]) + (#;Right [input (#;Some value)]) + ))) + +(def: #export (this text) + (-> Text (Lexer Text)) + (lambda [input] + (if (text;starts-with? text input) + (case (text;split (text;size text) input) + #;None (#;Left "") + (#;Some [_ input']) (#;Right [input' text])) + (#;Left (format "Invalid match: " text " @ " (:: text;Codec<Text,Text> encode input)))) + )) + +(def: #export (sep-by sep p) + (All [a b] (-> (Lexer b) (Lexer a) (Lexer (List a)))) + (do Monad<Lexer> + [?x (opt p)] + (case ?x + #;None + (wrap #;Nil) + + (#;Some x) + (do @ + [xs' (some (seq sep p))] + (wrap (#;Cons x (map product;right xs')))) + ))) + +(def: #export end + (Lexer Unit) + (lambda [input] + (case input + "" (#;Right [input []]) + _ (#;Left (format "The text input has not been fully consumed @ " (:: text;Codec<Text,Text> encode input))) + ))) + +(def: #export peek + (Lexer Char) + (lambda [input] + (case (text;at +0 input) + (#;Some output) + (#;Right [input output]) + + _ + (#;Left "Can't peek character from empty text.")) + )) + +(def: #export (this-char char) + (-> Char (Lexer Char)) + (lambda [input] + (case [(text;at +0 input) (text;split +1 input)] + [(#;Some char') (#;Some [_ input'])] + (if (Char/= char char') + (#;Right [input' char]) + (#;Left (format "Expected " (:: char;Codec<Text,Char> encode char) " @ " (:: text;Codec<Text,Text> encode input) + " " (Int/encode (c2l char))" " (Int/encode (c2l [char']))))) + + _ + (#;Left "Can't parse character from empty text.")) + )) + +(def: #export get-input + (Lexer Text) + (lambda [input] + (#;Right [input input]))) + +(def: #export (char-range bottom top) + (-> Char Char (Lexer Char)) + (do Monad<Lexer> + [input get-input + char any + _ (assert (and (Char/>= bottom char) + (Char/<= top char)) + (format "Character is not within range: " (:: char;Codec<Text,Char> encode bottom) "-" (:: char;Codec<Text,Char> encode top) " @ " (:: text;Codec<Text,Text> encode input)))] + (wrap char))) + +(do-template [<name> <bottom> <top>] + [(def: #export <name> + (Lexer Char) + (char-range <bottom> <top>))] + + [upper #"A" #"Z"] + [lower #"a" #"z"] + [digit #"0" #"9"] + [oct-digit #"0" #"7"] + ) + +(def: #export alpha + (Lexer Char) + (either lower upper)) + +(def: #export alpha-num + (Lexer Char) + (either alpha digit)) + +(def: #export hex-digit + (Lexer Char) + ($_ either + digit + (char-range #"a" #"f") + (char-range #"A" #"F"))) + +(def: #export (one-of options) + (-> Text (Lexer Char)) + (lambda [input] + (case (text;split +1 input) + (#;Some [init input']) + (if (text;contains? init options) + (case (text;at +0 init) + (#;Some output) + (#;Right [input' output]) + + _ + (#;Left "")) + (#;Left (format "Character (" init ") is not one of: " options " @ " (:: text;Codec<Text,Text> encode input)))) + + _ + (#;Left "Can't parse character from empty text.")))) + +(def: #export (none-of options) + (-> Text (Lexer Char)) + (lambda [input] + (case (text;split +1 input) + (#;Some [init input']) + (if (;not (text;contains? init options)) + (case (text;at +0 init) + (#;Some output) + (#;Right [input' output]) + + _ + (#;Left "")) + (#;Left (format "Character (" init ") is one of: " options " @ " (:: text;Codec<Text,Text> encode input)))) + + _ + (#;Left "Can't parse character from empty text.")))) + +(def: #export (satisfies p) + (-> (-> Char Bool) (Lexer Char)) + (lambda [input] + (case (: (Maybe [Text Char]) + (do Monad<Maybe> + [[init input'] (text;split +1 input) + output (text;at +0 init)] + (wrap [input' output]))) + (#;Some [input' output]) + (if (p output) + (#;Right [input' output]) + (#;Left (format "Character does not satisfy predicate: " (:: text;Codec<Text,Text> encode input)))) + + _ + (#;Left "Can't parse character from empty text.")))) + +(def: #export space + (Lexer Char) + (satisfies char;space?)) + +(def: #export (some' p) + (-> (Lexer Char) (Lexer Text)) + (do Monad<Lexer> + [cs (some p)] + (wrap (text;concat (map char;as-text cs))))) + +(def: #export (many' p) + (-> (Lexer Char) (Lexer Text)) + (do Monad<Lexer> + [cs (many p)] + (wrap (text;concat (map char;as-text cs))))) + +(def: #export end? + (Lexer Bool) + (lambda [input] + (#;Right [input (text;empty? input)]))) + +(def: #export (_& left right) + (All [a b] (-> (Lexer a) (Lexer b) (Lexer b))) + (do Monad<Lexer> + [_ left] + right)) + +(def: #export (&_ left right) + (All [a b] (-> (Lexer a) (Lexer b) (Lexer a))) + (do Monad<Lexer> + [output left + _ right] + (wrap output))) + +(def: #export (default value lexer) + (All [a] (-> a (Lexer a) (Lexer a))) + (lambda [input] + (case (lexer input) + (#;Left error) + (#;Right [input value]) + + (#;Right input'+value) + (#;Right input'+value)))) + +(def: #export (codec codec lexer) + (All [a] (-> (Codec Text a) (Lexer Text) (Lexer a))) + (lambda [input] + (case (lexer input) + (#;Left error) + (#;Left error) + + (#;Right [input' to-decode]) + (case (:: codec decode to-decode) + (#;Left error) + (#;Left error) + + (#;Right value) + (#;Right [input' value]))))) + +(def: #export (enclosed [start end] lexer) + (All [a] (-> [Text Text] (Lexer a) (Lexer a))) + (_& (this start) + (&_ lexer + (this end)))) diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux new file mode 100644 index 000000000..7c192cb2b --- /dev/null +++ b/stdlib/source/lux/macro.lux @@ -0,0 +1,31 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monad) + (data (struct [list "List/" Monad<List>]) + text/format) + [compiler] + (macro ["s" syntax #+ syntax: Syntax]))) + +(def: omit^ + (Syntax Bool) + (s;tag? ["" "omit"])) + +(do-template [<macro> <func>] + [(syntax: #export (<macro> {? omit^} token) + (do @ + [output (<func> token) + #let [_ (List/map (. log! %ast) + output)]] + (if ? + (wrap (list)) + (wrap output))))] + + [expand compiler;macro-expand] + [expand-all compiler;macro-expand-all] + [expand-once compiler;macro-expand-once] + ) diff --git a/stdlib/source/lux/macro/ast.lux b/stdlib/source/lux/macro/ast.lux new file mode 100644 index 000000000..cc1cffa5f --- /dev/null +++ b/stdlib/source/lux/macro/ast.lux @@ -0,0 +1,149 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control eq) + (data bool + number + [char] + [text #+ Eq<Text> "Text/" Monoid<Text>] + ident + (struct [list #* "" Functor<List> Fold<List>]) + ))) + +## [Types] +## (type: (AST' w) +## (#;BoolS Bool) +## (#;NatS Nat) +## (#;IntS Int) +## (#;RealS Real) +## (#;CharS Char) +## (#;TextS Text) +## (#;SymbolS Text Text) +## (#;TagS Text Text) +## (#;FormS (List (w (AST' w)))) +## (#;TupleS (List (w (AST' w)))) +## (#;RecordS (List [(w (AST' w)) (w (AST' w))]))) + +## (type: AST +## (Meta Cursor (AST' (Meta Cursor)))) + +## [Utils] +(def: _cursor Cursor ["" -1 -1]) + +## [Functions] +(do-template [<name> <type> <tag>] + [(def: #export (<name> x) + (-> <type> AST) + [_cursor (<tag> x)])] + + [bool Bool #;BoolS] + [nat Nat #;NatS] + [int Int #;IntS] + [frac Frac #;FracS] + [real Real #;RealS] + [char Char #;CharS] + [text Text #;TextS] + [symbol Ident #;SymbolS] + [tag Ident #;TagS] + [form (List AST) #;FormS] + [tuple (List AST) #;TupleS] + [record (List [AST AST]) #;RecordS] + ) + +(do-template [<name> <tag>] + [(def: #export (<name> name) + (-> Text AST) + [_cursor (<tag> ["" name])])] + + [local-symbol #;SymbolS] + [local-tag #;TagS]) + +## [Structures] +(struct: #export _ (Eq AST) + (def: (= x y) + (case [x y] + (^template [<tag> <eq>] + [[_ (<tag> x')] [_ (<tag> y')]] + (:: <eq> = x' y')) + ([#;BoolS Eq<Bool>] + [#;NatS Eq<Nat>] + [#;IntS Eq<Int>] + [#;FracS Eq<Frac>] + [#;RealS Eq<Real>] + [#;CharS char;Eq<Char>] + [#;TextS Eq<Text>] + [#;SymbolS Eq<Ident>] + [#;TagS Eq<Ident>]) + + (^template [<tag>] + [[_ (<tag> xs')] [_ (<tag> ys')]] + (and (:: Eq<Nat> = (size xs') (size ys')) + (fold (lambda [[x' y'] old] + (and old (= x' y'))) + true + (zip2 xs' ys')))) + ([#;FormS] + [#;TupleS]) + + [[_ (#;RecordS xs')] [_ (#;RecordS ys')]] + (and (:: Eq<Nat> = (size xs') (size ys')) + (fold (lambda [[[xl' xr'] [yl' yr']] old] + (and old (= xl' yl') (= xr' yr'))) + true + (zip2 xs' ys'))) + + _ + false))) + +## [Values] +(def: #export (ast-to-text ast) + (-> AST Text) + (case ast + (^template [<tag> <struct>] + [_ (<tag> value)] + (:: <struct> encode value)) + ([#;BoolS Codec<Text,Bool>] + [#;NatS Codec<Text,Nat>] + [#;IntS Codec<Text,Int>] + [#;FracS Codec<Text,Frac>] + [#;RealS Codec<Text,Real>] + [#;CharS char;Codec<Text,Char>] + [#;TextS text;Codec<Text,Text>] + [#;SymbolS Codec<Text,Ident>]) + + [_ (#;TagS ident)] + (Text/append "#" (:: Codec<Text,Ident> encode ident)) + + (^template [<tag> <open> <close>] + [_ (<tag> members)] + ($_ Text/append <open> (|> members (map ast-to-text) (interpose " ") (text;join-with "")) <close>)) + ([#;FormS "(" ")"] + [#;TupleS "[" "]"]) + + [_ (#;RecordS pairs)] + ($_ Text/append "{" (|> pairs (map (lambda [[left right]] ($_ Text/append (ast-to-text left) " " (ast-to-text right)))) (interpose " ") (text;join-with "")) "}") + )) + +(def: #export (replace source target ast) + (-> AST AST AST AST) + (if (:: Eq<AST> = source ast) + target + (case ast + (^template [<tag>] + [cursor (<tag> parts)] + [cursor (<tag> (map (replace source target) parts))]) + ([#;FormS] + [#;TupleS]) + + [cursor (#;RecordS parts)] + [cursor (#;RecordS (map (lambda [[left right]] + [(replace source target left) + (replace source target right)]) + parts))] + + _ + ast))) diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux new file mode 100644 index 000000000..ac7043f26 --- /dev/null +++ b/stdlib/source/lux/macro/poly.lux @@ -0,0 +1,364 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + [lux #- list] + (lux (control monad + [eq]) + (data [text] + text/format + (struct [list "List/" Monad<List>] + [dict #+ Dict]) + [number] + [product] + [bool] + [char] + [maybe]) + [compiler #+ Monad<Lux> with-gensyms] + (macro [ast] + ["s" syntax #+ syntax: Syntax] + (syntax [common])) + [type] + )) + +## [Types] +(type: #export (Matcher a) + (-> Type (Lux a))) + +(type: #export Env (Dict Nat AST)) + +## [Combinators] +(do-template [<combinator> <name>] + [(def: #export <combinator> + (Matcher Unit) + (lambda [:type:] + (case (type;un-alias :type:) + (#;NamedT ["lux" <name>] _) + (:: compiler;Monad<Lux> wrap []) + + _ + (compiler;fail (format "Not " <name> " type: " (type;type-to-text :type:))))))] + + [unit "Unit"] + [bool "Bool"] + [nat "Nat"] + [int "Int"] + [frac "Frac"] + [real "Real"] + [char "Char"] + [text "Text"] + ) + +(def: #export primitive + (Matcher Type) + (lambda [:type:] + (let% [<primitives> (do-template [<parser> <type>] + [(do Monad<Lux> + [_ (<parser> :type:)] + (wrap <type>))] + + [bool Bool] + [nat Nat] + [int Int] + [frac Frac] + [real Real] + [char Char] + [text Text])] + ($_ compiler;either + <primitives>)))) + +(syntax: ($AST$ ast) + (wrap (;list (ast;text (ast;ast-to-text ast))))) + +(do-template [<single> <multi> <flattener> <tag>] + [(def: #export <single> + (Matcher [Type Type]) + (lambda [:type:] + (case (type;un-name :type:) + (<tag> :left: :right:) + (:: compiler;Monad<Lux> wrap [:left: :right:]) + + _ + (compiler;fail (format "Not a " ($AST$ <tag>) " type: " (type;type-to-text :type:)))))) + + (def: #export <multi> + (Matcher (List Type)) + (lambda [:type:] + (let [members (<flattener> (type;un-name :type:))] + (if (>+ +1 (list;size members)) + (:: compiler;Monad<Lux> wrap members) + (compiler;fail (format "Not a " ($AST$ <tag>) " type: " (type;type-to-text :type:)))))))] + + [sum sum+ type;flatten-sum #;SumT] + [prod prod+ type;flatten-prod #;ProdT] + ) + +(def: #export func + (Matcher [Type Type]) + (lambda [:type:] + (case (type;un-name :type:) + (#;LambdaT :left: :right:) + (:: compiler;Monad<Lux> wrap [:left: :right:]) + + _ + (compiler;fail (format "Not a LambdaT type: " (type;type-to-text :type:)))))) + +(def: #export func+ + (Matcher [(List Type) Type]) + (lambda [:type:] + (let [[ins out] (type;flatten-function (type;un-name :type:))] + (if (>+ +0 (list;size ins)) + (:: compiler;Monad<Lux> wrap [ins out]) + (compiler;fail (format "Not a LambdaT type: " (type;type-to-text :type:))))))) + +(def: #export tagged + (Matcher [(List Ident) Type]) + (lambda [:type:] + (case (type;un-alias :type:) + (#;NamedT type-name :def:) + (do compiler;Monad<Lux> + [tags (compiler;tags-of type-name)] + (wrap [tags :def:])) + + _ + (compiler;fail (format "Unnamed types can't have tags: " (type;type-to-text :type:)))))) + +(def: #export polymorphic + (Matcher [(List AST) Type]) + (lambda [:type:] + (loop [:type: (type;un-name :type:)] + (case :type: + (#;UnivQ _ :type:') + (do compiler;Monad<Lux> + [[g!tail :type:''] (recur :type:') + g!head (compiler;gensym "type-var")] + (wrap [(list& g!head g!tail) + :type:''])) + + _ + (:: compiler;Monad<Lux> wrap [(;list) :type:]))))) + +(do-template [<combinator> <sub-comb>] + [(def: #export <combinator> + (Matcher [(List AST) (List [Ident Type])]) + (lambda [:type:] + (do compiler;Monad<Lux> + [[tags :type:] (tagged :type:) + _ (compiler;assert (>+ +0 (list;size tags)) "Records and variants must have tags.") + [vars :type:] (polymorphic :type:) + members (<sub-comb> :type:)] + (wrap [vars (list;zip2 tags members)]))))] + + [variant sum+] + [record prod+] + ) + +(def: #export tuple + (Matcher [(List AST) (List Type)]) + (lambda [:type:] + (do compiler;Monad<Lux> + [[vars :type:] (polymorphic :type:) + members (prod+ :type:)] + (wrap [vars members])))) + +(def: #export function + (Matcher [(List AST) [(List Type) Type]]) + (lambda [:type:] + (do compiler;Monad<Lux> + [[vars :type:] (polymorphic :type:) + ins+out (func+ :type:)] + (wrap [vars ins+out])))) + +(def: #export apply + (Matcher [Type (List Type)]) + (lambda [:type:] + (do compiler;Monad<Lux> + [#let [[:func: :args:] (loop [:type: (type;un-name :type:)] + (case :type: + (#;AppT :func: :arg:) + (let [[:func:' :args:] (recur :func:)] + [:func:' (list& :arg: :args:)]) + + _ + [:type: (;list)]))]] + (case :args: + #;Nil + (compiler;fail "Not a type application.") + + _ + (wrap [:func: (list;reverse :args:)]))))) + +(do-template [<combinator> <name>] + [(def: #export <combinator> + (Matcher Type) + (lambda [:type:] + (case (type;un-name :type:) + (^=> (#;AppT :quant: :arg:) + {(type;un-alias :quant:) (#;NamedT ["lux" <name>] _)}) + (:: compiler;Monad<Lux> wrap :arg:) + + _ + (compiler;fail (format "Not " <name> " type: " (type;type-to-text :type:))))))] + + [maybe "Maybe"] + [list "List"] + ) + +(def: (adjusted-idx env idx) + (-> Env Nat Nat) + (let [env-level (/+ +2 (dict;size env)) + bound-level (/+ +2 idx) + bound-idx (%+ +2 idx)] + (|> env-level dec+ (-+ bound-level) (*+ +2) (++ bound-idx)))) + +(def: #export (bound env) + (-> Env (Matcher AST)) + (lambda [:type:] + (case :type: + (#;BoundT idx) + (case (dict;get (adjusted-idx env idx) env) + (#;Some poly-val) + (:: compiler;Monad<Lux> wrap poly-val) + + #;None + (compiler;fail (format "Unknown bound type: " (type;type-to-text :type:)))) + + _ + (compiler;fail (format "Not a bound type: " (type;type-to-text :type:)))))) + +(def: #export (var env var-id) + (-> Env Nat (Matcher Unit)) + (lambda [:type:] + (case :type: + (^=> (#;BoundT idx) + (=+ var-id (adjusted-idx env idx))) + (:: compiler;Monad<Lux> wrap []) + + _ + (compiler;fail (format "Not a bound type: " (type;type-to-text :type:)))))) + +(def: #export (recur env) + (-> Env (Matcher Unit)) + (lambda [:type:] + (do Monad<Lux> + [[t-fun t-args] (apply :type:)] + (loop [base +0 + :parts: (list& t-fun t-args)] + (case :parts: + #;Nil + (wrap []) + + (^=> (#;Cons (#;BoundT idx) :parts:') + {(adjusted-idx env idx) + idx'} + (=+ base idx')) + (recur (inc+ base) :parts:') + + _ + (compiler;fail (format "Type is not a recursive instance: " (type;type-to-text :type:))))) + ))) + +## [Syntax] +(def: #export (extend-env type-func type-vars env) + (-> AST (List AST) Env Env) + (case type-vars + #;Nil + env + + (#;Cons tvar type-vars') + (let [current-size (dict;size env)] + (|> env + (dict;put current-size type-func) + (dict;put (inc+ current-size) tvar) + (extend-env (` (#;AppT (~ type-func) (~ tvar))) type-vars') + )))) + +(syntax: #export (poly: {_ex-lev common;export-level} + {[name env inputs] (s;form ($_ s;seq + s;local-symbol + s;local-symbol + (s;many s;local-symbol)))} + body) + (with-gensyms [g!body] + (let [g!inputs (List/map (|>. [""] ast;symbol) inputs) + g!name (ast;symbol ["" name]) + g!env (ast;symbol ["" env])] + (wrap (;list (` (syntax: (~@ (common;gen-export-level _ex-lev)) ((~ g!name) (~@ (List/map (lambda [g!input] (` {(~ g!input) s;symbol})) + g!inputs))) + (do Monad<Lux> + [(~@ (List/join (List/map (lambda [g!input] (;list g!input (` (compiler;find-type-def (~ g!input))))) + g!inputs))) + (~' #let) [(~ g!env) (: Env (dict;new number;Hash<Nat>))] + (~ g!body) (: (Lux AST) + (loop [(~ g!env) (~ g!env) + (~@ (List/join (List/map (lambda [g!input] (;list g!input g!input)) + g!inputs)))] + (let [(~ g!name) (~' recur)] + (~ body))))] + ((~' wrap) (;list (~ g!body))))))))))) + +(def: (common-poly-name? poly-func) + (-> Text Bool) + (and (text;starts-with? "|" poly-func) + (text;ends-with? "|" poly-func))) + +(def: (derivation-name poly args) + (-> Text (List Text) (Maybe Text)) + (if (common-poly-name? poly) + (case (text;sub +1 (dec+ (text;size poly)) poly) + (#;Some clean-poly) + (case (list;reverse args) + #;Nil + #;None + + (#;Cons type #;Nil) + (#;Some (format type "/" clean-poly)) + + (#;Cons type args) + (#;Some (format type "/" clean-poly "@" (|> args list;reverse (text;join-with ","))))) + + #;None + #;None) + #;None)) + +(syntax: #export (derived: {_ex-lev common;export-level} + {?name (s;opt s;local-symbol)} + {[poly-func poly-args] (s;either (s;form (s;seq s;symbol (s;many s;symbol))) + (s;seq s;symbol (:: @ wrap (;list))))} + {?custom-impl (s;opt s;any)}) + (do @ + [name (case ?name + (#;Some name) + (wrap name) + + (^=> #;None + {(derivation-name (product;right poly-func) (List/map product;right poly-args)) + (#;Some derived-name)}) + (wrap derived-name) + + _ + (compiler;fail "derived: was given no explicit name, and can't generate one from given information.")) + #let [impl (case ?custom-impl + (#;Some custom-impl) + custom-impl + + #;None + (` ((~ (ast;symbol poly-func)) (~@ (List/map ast;symbol poly-args)))))]] + (wrap (;list (` (def: (~@ (common;gen-export-level _ex-lev)) + (~ (ast;symbol ["" name])) + (~ impl))))))) + +## [Derivers] +(def: #export (gen-type converter type-fun tvars type) + (-> (-> AST AST) AST (List AST) Type AST) + (let [type' (type;type-to-ast type)] + (case tvars + #;Nil + (converter type') + + _ + (` (All (~ type-fun) [(~@ tvars)] + (-> (~@ (List/map converter tvars)) + (~ (converter (` ((~ type') (~@ tvars))))))))))) diff --git a/stdlib/source/lux/macro/poly/eq.lux b/stdlib/source/lux/macro/poly/eq.lux new file mode 100644 index 000000000..b0506c5ed --- /dev/null +++ b/stdlib/source/lux/macro/poly/eq.lux @@ -0,0 +1,103 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monad + [eq]) + (data [text] + text/format + (struct [list "List/" Monad<List>] + [dict #+ Dict]) + [number] + [product] + [bool] + [char] + [maybe]) + [compiler #+ Monad<Lux> with-gensyms] + (macro [ast] + [syntax #+ syntax: Syntax] + (syntax [common]) + [poly #+ poly:]) + [type] + )) + +## [Derivers] +(poly: #export (|Eq| env :x:) + (let [->Eq (: (-> AST AST) + (lambda [.type.] (` (eq;Eq (~ .type.)))))] + (let% [<basic> (do-template [<type> <matcher> <eq>] + [(do @ + [_ (<matcher> :x:)] + (wrap (` (: (~ (->Eq (` <type>))) + <eq>))))] + + [Unit poly;unit (lambda [(~' test) (~' input)] true)] + [Bool poly;bool bool;Eq<Bool>] + [Nat poly;nat number;Eq<Nat>] + [Int poly;int number;Eq<Int>] + [Frac poly;frac number;Eq<Frac>] + [Real poly;real number;Eq<Real>] + [Char poly;char char;Eq<Char>] + [Text poly;text text;Eq<Text>])] + ($_ compiler;either + ## Primitive types + <basic> + ## Variants + (with-gensyms [g!type-fun g!left g!right] + (do @ + [[g!vars cases] (poly;variant :x:) + #let [new-env (poly;extend-env g!type-fun g!vars env)] + pattern-matching (mapM @ + (lambda [[name :case:]] + (do @ + [encoder (|Eq| new-env :case:)] + (wrap (list (` [((~ (ast;tag name)) (~ g!left)) + ((~ (ast;tag name)) (~ g!right))]) + (` ((~ encoder) (~ g!left) (~ g!right))))))) + cases)] + (wrap (` (: (~ (poly;gen-type ->Eq g!type-fun g!vars :x:)) + (lambda [(~@ g!vars)] + (lambda [(~ g!left) (~ g!right)] + (case [(~ g!left) (~ g!right)] + (~@ (List/join pattern-matching))))) + ))))) + ## Tuples + (with-gensyms [g!type-fun g!left g!right] + (do @ + [[g!vars members] (poly;tuple :x:) + #let [new-env (poly;extend-env g!type-fun g!vars env)] + pattern-matching (mapM @ + (lambda [:member:] + (do @ + [g!left (compiler;gensym "g!left") + g!right (compiler;gensym "g!right") + encoder (|Eq| new-env :member:)] + (wrap [g!left g!right encoder]))) + members) + #let [.left. (` [(~@ (List/map product;left pattern-matching))]) + .right. (` [(~@ (List/map (|>. product;right product;left) pattern-matching))])]] + (wrap (` (: (~ (poly;gen-type ->Eq g!type-fun g!vars :x:)) + (lambda [(~@ g!vars)] + (lambda [(~ g!left) (~ g!right)] + (case [(~ g!left) (~ g!right)] + [(~ .left.) (~ .right.)] + (;;array (list (~@ (List/map (lambda [[g!left g!right g!encoder]] + (` ((~ g!encoder) (~ g!left) (~ g!right)))) + pattern-matching))))))) + ))) + )) + ## Type applications + (do @ + [[:func: :args:] (poly;apply :x:) + .func. (|Eq| env :func:) + .args. (mapM @ (|Eq| env) :args:)] + (wrap (` (: (~ (->Eq (type;type-to-ast :x:))) + ((~ .func.) (~@ .args.)))))) + ## Bound type-vars + (poly;bound env :x:) + ## If all else fails... + (compiler;fail (format "Can't create Eq for: " (type;type-to-text :x:))) + )))) diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux new file mode 100644 index 000000000..78b668f2c --- /dev/null +++ b/stdlib/source/lux/macro/poly/functor.lux @@ -0,0 +1,126 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monad + [functor]) + (data [text] + text/format + (struct [list "List/" Monad<List>] + [dict #+ Dict]) + [number] + [product] + [bool] + [char] + [maybe] + [ident "Ident/" Codec<Text,Ident>] + error) + [compiler #+ Monad<Lux> with-gensyms] + (macro [ast] + [syntax #+ syntax: Syntax] + (syntax [common]) + [poly #+ poly:]) + [type] + )) + +## [Derivers] +(poly: #export (|Functor| env :x:) + (with-gensyms [g!type-fun g!func g!input] + (do @ + [#let [g!map (' map)] + [g!vars _] (poly;polymorphic :x:) + #let [num-vars (list;size g!vars) + new-env (poly;extend-env g!type-fun g!vars env)] + _ (compiler;assert (>+ +0 num-vars) + "Functors must have at least 1 type-variable.")] + (let [->Functor (: (-> AST AST) + (lambda [.type.] (` (functor;Functor (~ .type.))))) + |elem| (: (-> AST (poly;Matcher AST)) + (lambda |elem| [value :type:] + ($_ compiler;either + ## Nothing to do. + (do @ + [_ (poly;primitive :type:)] + (wrap value)) + ## Type-var + (do @ + [_ (poly;var new-env (dec+ num-vars) :type:)] + (wrap (` ((~ g!func) (~ value))))) + ## Tuples/records + (do @ + [[g!vars members] (poly;tuple :x:) + pm (mapM @ + (lambda [:slot:] + (do @ + [g!slot (compiler;gensym "g!slot") + body (|elem| g!slot :slot:)] + (wrap [g!slot body]))) + members)] + (wrap (` (case (~ g!input) + [(~@ (List/map product;left pm))] + [(~@ (List/map product;right pm))]) + ))) + ## Recursion + (do @ + [_ (poly;recur new-env :type:)] + (wrap (` ((~ g!map) (~ g!func) (~ value))))) + )))] + ($_ compiler;either + ## Variants + (do @ + [[g!vars cases] (poly;variant :x:) + pattern-matching (mapM @ + (lambda [[name :case:]] + (do @ + [#let [analysis (` ((~ (ast;tag name)) (~ g!input)))] + synthesis (|elem| g!input :case:)] + (wrap (list analysis + synthesis)))) + cases)] + (wrap (` (: (~ (->Functor (type;type-to-ast :x:))) + (struct (def: ((~ g!map) (~ g!func) (~ g!input)) + (case (~ g!input) + (~@ (List/join pattern-matching))))) + )))) + ## Tuples/Records + (do @ + [[g!vars members] (poly;tuple :x:) + pm (mapM @ + (lambda [:slot:] + (do @ + [g!slot (compiler;gensym "g!slot") + body (|elem| g!slot :slot:)] + (wrap [g!slot body]))) + members)] + (wrap (` (: (~ (->Functor (type;type-to-ast :x:))) + (struct (def: ((~ g!map) (~ g!func) (~ g!input)) + (case (~ g!input) + [(~@ (List/map product;left pm))] + [(~@ (List/map product;right pm))]))) + )))) + ## Functions + (with-gensyms [g!out] + (do @ + [[g!vars [:ins: :out:]] (poly;function :x:) + .out. (|elem| g!out :out:) + g!ins (seqM @ + (list;repeat (list;size :ins:) + (compiler;gensym "g!arg")))] + (wrap (` (: (~ (->Functor (type;type-to-ast :x:))) + (struct (def: ((~ g!map) (~ g!func) (~ g!input)) + (lambda [(~@ g!ins)] + (let [(~ g!out) ((~ g!input) (~@ g!ins))] + (~ .out.)))))))))) + ## No structure (as you'd expect from Identity) + (do @ + [_ (poly;var new-env (dec+ num-vars) :x:)] + (wrap (` (: (~ (->Functor (type;type-to-ast :x:))) + (struct (def: ((~ g!map) (~ g!func) (~ g!input)) + ((~ g!func) (~ g!input)))))))) + ## Failure... + (compiler;fail (format "Can't create Functor for: " (type;type-to-text :x:))) + )) + ))) diff --git a/stdlib/source/lux/macro/poly/text-encoder.lux b/stdlib/source/lux/macro/poly/text-encoder.lux new file mode 100644 index 000000000..49d06daf4 --- /dev/null +++ b/stdlib/source/lux/macro/poly/text-encoder.lux @@ -0,0 +1,126 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monad + [codec]) + (data [text] + text/format + (struct [list "List/" Monad<List>] + [dict #+ Dict]) + [number] + [product] + [bool] + [char] + [maybe] + [ident "Ident/" Codec<Text,Ident>] + error) + [compiler #+ Monad<Lux> with-gensyms] + (macro [ast] + [syntax #+ syntax: Syntax] + (syntax [common]) + [poly #+ poly:]) + [type] + )) + +## [Derivers] +(poly: #export (|Codec@Text//encode| env :x:) + (let [->Codec//encode (: (-> AST AST) + (lambda [.type.] (` (-> (~ .type.) Text))))] + (let% [<basic> (do-template [<type> <matcher> <encoder>] + [(do @ + [_ (<matcher> :x:)] + (wrap (` (: (~ (->Codec//encode (` <type>))) + (~' <encoder>)))))] + + [Unit poly;unit (lambda [_0] "[]")] + [Bool poly;bool (:: bool;Codec<Text,Bool> encode)] + [Nat poly;nat (:: number;Codec<Text,Nat> encode)] + [Int poly;int (:: number;Codec<Text,Int> encode)] + [Frac poly;frac (:: number;Codec<Text,Frac> encode)] + [Real poly;real (:: number;Codec<Text,Real> encode)] + [Char poly;char (:: char;Codec<Text,Char> encode)] + [Text poly;text (:: text;Codec<Text,Text> encode)])] + ($_ compiler;either + ## Primitives + <basic> + ## Variants + (with-gensyms [g!type-fun g!case g!input] + (do @ + [[g!vars cases] (poly;variant :x:) + #let [new-env (poly;extend-env g!type-fun g!vars env)] + pattern-matching (mapM @ + (lambda [[name :case:]] + (do @ + [encoder (|Codec@Text//encode| new-env :case:)] + (wrap (list (` ((~ (ast;tag name)) (~ g!case))) + (` (format "(#" + (~ (ast;text (Ident/encode name))) + " " + ((~ encoder) (~ g!case)) + ")")))))) + cases)] + (wrap (` (: (~ (poly;gen-type ->Codec//encode g!type-fun g!vars :x:)) + (lambda [(~@ g!vars)] + (lambda [(~ g!input)] + (case (~ g!input) + (~@ (List/join pattern-matching))))) + ))))) + ## Records + (with-gensyms [g!type-fun g!case g!input] + (do @ + [[g!vars slots] (poly;record :x:) + #let [new-env (poly;extend-env g!type-fun g!vars env)] + synthesis (mapM @ + (lambda [[name :slot:]] + (do @ + [encoder (|Codec@Text//encode| new-env :slot:)] + (wrap (` (format "#" + (~ (ast;text (Ident/encode name))) + " " + ((~ encoder) (get@ (~ (ast;tag name)) (~ g!input)))))))) + slots)] + (wrap (` (: (~ (poly;gen-type ->Codec//encode g!type-fun g!vars :x:)) + (lambda [(~@ g!vars)] + (lambda [(~ g!input)] + (format "{" (~@ (list;interpose (' " ") synthesis)) "}"))) + ))))) + ## Tuples + (with-gensyms [g!type-fun g!case g!input] + (do @ + [[g!vars members] (poly;tuple :x:) + #let [new-env (poly;extend-env g!type-fun g!vars env)] + parts (mapM @ + (lambda [:member:] + (do @ + [g!member (compiler;gensym "g!member") + encoder (|Codec@Text//encode| new-env :member:)] + (wrap [g!member encoder]))) + members) + #let [analysis (` [(~@ (List/map product;left parts))]) + synthesis (List/map (lambda [[g!member g!encoder]] + (` ((~ g!encoder) (~ g!member)))) + parts)]] + (wrap (` (: (~ (poly;gen-type ->Codec//encode g!type-fun g!vars :x:)) + (lambda [(~@ g!vars)] + (lambda [(~ g!input)] + (case (~ g!input) + (~ analysis) + (format "[" (~@ (list;interpose (' " ") synthesis)) "]")))) + ))) + )) + ## Type applications + (do @ + [[:func: :args:] (poly;apply :x:) + .func. (|Codec@Text//encode| env :func:) + .args. (mapM @ (|Codec@Text//encode| env) :args:)] + (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:))) + ((~ .func.) (~@ .args.)))))) + ## Bound type-variables + (poly;bound env :x:) + ## Failure... + (compiler;fail (format "Can't create Text encoder for: " (type;type-to-text :x:))) + )))) diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux new file mode 100644 index 000000000..367dc10b6 --- /dev/null +++ b/stdlib/source/lux/macro/syntax.lux @@ -0,0 +1,472 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + [lux #- not default] + (lux [compiler #+ Monad<Lux> with-gensyms] + (control functor + applicative + monad + eq) + (data [bool] + [char] + [number] + [text "Text/" Monoid<Text>] + [ident] + (struct [list #* "" Functor<List> Fold<List> "List/" Monoid<List>]) + [product] + error)) + (.. [ast])) + +## [Utils] +(def: (join-pairs pairs) + (All [a] (-> (List [a a]) (List a))) + (case pairs + #;Nil #;Nil + (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs')))) + +## [Types] +(type: #export (Syntax a) + (-> (List AST) (Error [(List AST) a]))) + +## [Structures] +(struct: #export _ (Functor Syntax) + (def: (map f ma) + (lambda [tokens] + (case (ma tokens) + (#;Left msg) + (#;Left msg) + + (#;Right [tokens' a]) + (#;Right [tokens' (f a)]))))) + +(struct: #export _ (Applicative Syntax) + (def: functor Functor<Syntax>) + + (def: (wrap x tokens) + (#;Right [tokens x])) + + (def: (apply ff fa) + (lambda [tokens] + (case (ff tokens) + (#;Right [tokens' f]) + (case (fa tokens') + (#;Right [tokens'' a]) + (#;Right [tokens'' (f a)]) + + (#;Left msg) + (#;Left msg)) + + (#;Left msg) + (#;Left msg))))) + +(struct: #export _ (Monad Syntax) + (def: applicative Applicative<Syntax>) + + (def: (join mma) + (lambda [tokens] + (case (mma tokens) + (#;Left msg) + (#;Left msg) + + (#;Right [tokens' ma]) + (ma tokens'))))) + +## [Utils] +(def: (remaining-inputs asts) + (-> (List AST) Text) + ($_ Text/append " | Remaining input: " + (|> asts (map ast;ast-to-text) (interpose " ") (text;join-with "")))) + +## [Syntaxs] +(def: #export any + {#;doc "Just returns the next input without applying any logic."} + (Syntax AST) + (lambda [tokens] + (case tokens + #;Nil (#;Left "There are no tokens to parse!") + (#;Cons [t tokens']) (#;Right [tokens' t])))) + +(do-template [<get-name> <ask-name> <demand-name> <type> <tag> <eq> <desc>] + [(def: #export <get-name> + (Syntax <type>) + (lambda [tokens] + (case tokens + (#;Cons [[_ (<tag> x)] tokens']) + (#;Right [tokens' x]) + + _ + (#;Left ($_ Text/append "Can't parse " <desc> (remaining-inputs tokens)))))) + + (def: #export (<ask-name> v) + (-> <type> (Syntax Bool)) + (lambda [tokens] + (case tokens + (#;Cons [[_ (<tag> x)] tokens']) + (let [is-it? (:: <eq> = v x) + remaining (if is-it? + tokens' + tokens)] + (#;Right [remaining is-it?])) + + _ + (#;Right [tokens false])))) + + (def: #export (<demand-name> v) + (-> <type> (Syntax Unit)) + (lambda [tokens] + (case tokens + (#;Cons [[_ (<tag> x)] tokens']) + (if (:: <eq> = v x) + (#;Right [tokens' []]) + (#;Left ($_ Text/append "Expected a " <desc> " but instead got " (ast;ast-to-text [_ (<tag> x)]) (remaining-inputs tokens)))) + + _ + (#;Left ($_ Text/append "Can't parse " <desc> (remaining-inputs tokens))))))] + + [ bool bool? bool! Bool #;BoolS bool;Eq<Bool> "bool"] + [ nat nat? nat! Nat #;NatS number;Eq<Nat> "nat"] + [ int int? int! Int #;IntS number;Eq<Int> "int"] + [ real real? real! Real #;RealS number;Eq<Real> "real"] + [ char char? char! Char #;CharS char;Eq<Char> "char"] + [ text text? text! Text #;TextS text;Eq<Text> "text"] + [symbol symbol? symbol! Ident #;SymbolS ident;Eq<Ident> "symbol"] + [ tag tag? tag! Ident #;TagS ident;Eq<Ident> "tag"] + ) + +(def: #export (assert v message) + (-> Bool Text (Syntax Unit)) + (lambda [tokens] + (if v + (#;Right [tokens []]) + (#;Left ($_ Text/append message (remaining-inputs tokens)))))) + +(do-template [<name> <comp> <error>] + [(def: #export <name> + (Syntax Int) + (do Monad<Syntax> + [n int + _ (assert (<comp> 0 n) <error>)] + (wrap n)))] + + [pos-int > "Expected a positive integer: N > 0"] + [neg-int < "Expected a negative integer: N < 0"] + ) + +(do-template [<name> <tag> <desc>] + [(def: #export <name> + (Syntax Text) + (lambda [tokens] + (case tokens + (#;Cons [[_ (<tag> ["" x])] tokens']) + (#;Right [tokens' x]) + + _ + (#;Left ($_ Text/append "Can't parse " <desc> (remaining-inputs tokens))))))] + + [local-symbol #;SymbolS "local symbol"] + [ local-tag #;TagS "local tag"] + ) + +(do-template [<name> <tag> <desc>] + [(def: #export (<name> p) + (All [a] + (-> (Syntax a) (Syntax a))) + (lambda [tokens] + (case tokens + (#;Cons [[_ (<tag> members)] tokens']) + (case (p members) + (#;Right [#;Nil x]) (#;Right [tokens' x]) + _ (#;Left ($_ Text/append "Syntax was expected to fully consume " <desc> (remaining-inputs tokens)))) + + _ + (#;Left ($_ Text/append "Can't parse " <desc> (remaining-inputs tokens))))))] + + [ form #;FormS "form"] + [tuple #;TupleS "tuple"] + ) + +(def: #export (record p) + (All [a] + (-> (Syntax a) (Syntax a))) + (lambda [tokens] + (case tokens + (#;Cons [[_ (#;RecordS pairs)] tokens']) + (case (p (join-pairs pairs)) + (#;Right [#;Nil x]) (#;Right [tokens' x]) + _ (#;Left ($_ Text/append "Syntax was expected to fully consume record" (remaining-inputs tokens)))) + + _ + (#;Left ($_ Text/append "Can't parse record" (remaining-inputs tokens)))))) + +(def: #export (opt p) + {#;doc "Optionality combinator."} + (All [a] + (-> (Syntax a) (Syntax (Maybe a)))) + (lambda [tokens] + (case (p tokens) + (#;Left _) (#;Right [tokens #;None]) + (#;Right [tokens' x]) (#;Right [tokens' (#;Some x)])))) + +(def: #export (run tokens p) + (All [a] + (-> (List AST) (Syntax a) (Error [(List AST) a]))) + (p tokens)) + +(def: #export (some p) + {#;doc "0-or-more combinator."} + (All [a] + (-> (Syntax a) (Syntax (List a)))) + (lambda [tokens] + (case (p tokens) + (#;Left _) (#;Right [tokens (list)]) + (#;Right [tokens' x]) (run tokens' + (do Monad<Syntax> + [xs (some p)] + (wrap (list& x xs))) + )))) + +(def: #export (many p) + {#;doc "1-or-more combinator."} + (All [a] + (-> (Syntax a) (Syntax (List a)))) + (do Monad<Syntax> + [x p + xs (some p)] + (wrap (list& x xs)))) + +(def: #export (seq p1 p2) + {#;doc "Sequencing combinator."} + (All [a b] + (-> (Syntax a) (Syntax b) (Syntax [a b]))) + (do Monad<Syntax> + [x1 p1 + x2 p2] + (wrap [x1 x2]))) + +(def: #export (alt p1 p2) + {#;doc "Heterogeneous alternative combinator."} + (All [a b] + (-> (Syntax a) (Syntax b) (Syntax (| a b)))) + (lambda [tokens] + (case (p1 tokens) + (#;Right [tokens' x1]) (#;Right [tokens' (+0 x1)]) + (#;Left _) (run tokens + (do Monad<Syntax> + [x2 p2] + (wrap (+1 x2)))) + ))) + +(def: #export (either pl pr) + {#;doc "Homogeneous alternative combinator."} + (All [a] + (-> (Syntax a) (Syntax a) (Syntax a))) + (lambda [tokens] + (case (pl tokens) + (#;Left _) (pr tokens) + output output + ))) + +(def: #export end + {#;doc "Ensures there are no more inputs."} + (Syntax Unit) + (lambda [tokens] + (case tokens + #;Nil (#;Right [tokens []]) + _ (#;Left ($_ Text/append "Expected list of tokens to be empty!" (remaining-inputs tokens)))))) + +(def: #export end? + {#;doc "Checks whether there are no more inputs."} + (Syntax Bool) + (lambda [tokens] + (case tokens + #;Nil (#;Right [tokens true]) + _ (#;Right [tokens false])))) + +(def: #export (exactly n p) + (All [a] (-> Nat (Syntax a) (Syntax (List a)))) + (if (>+ +0 n) + (do Monad<Syntax> + [x p + xs (exactly (dec+ n) p)] + (wrap (#;Cons x xs))) + (:: Monad<Syntax> wrap (list)))) + +(def: #export (at-least n p) + (All [a] (-> Nat (Syntax a) (Syntax (List a)))) + (do Monad<Syntax> + [min (exactly n p) + extra (some p)] + (wrap (List/append min extra)))) + +(def: #export (at-most n p) + (All [a] (-> Nat (Syntax a) (Syntax (List a)))) + (if (>+ +0 n) + (lambda [input] + (case (p input) + (#;Left msg) + (#;Right [input (list)]) + + (#;Right [input' x]) + (run input' + (do Monad<Syntax> + [xs (at-most (dec+ n) p)] + (wrap (#;Cons x xs)))) + )) + (:: Monad<Syntax> wrap (list)))) + +(def: #export (between from to p) + (All [a] (-> Nat Nat (Syntax a) (Syntax (List a)))) + (do Monad<Syntax> + [min-xs (exactly from p) + max-xs (at-most (-+ from to) p)] + (wrap (:: Monad<List> join (list min-xs max-xs))))) + +(def: #export (sep-by sep p) + {#;doc "Parsers instances of 'p' that are separated by instances of 'sep'."} + (All [a b] (-> (Syntax b) (Syntax a) (Syntax (List a)))) + (do Monad<Syntax> + [?x (opt p)] + (case ?x + #;None + (wrap #;Nil) + + (#;Some x) + (do @ + [xs' (some (seq sep p))] + (wrap (#;Cons x (map product;right xs')))) + ))) + +(def: #export (not p) + (All [a] (-> (Syntax a) (Syntax Unit))) + (lambda [input] + (case (p input) + (#;Left msg) + (#;Right [input []]) + + _ + (#;Left "Expected to fail; yet succeeded.")))) + +(def: #export (fail message) + (All [a] (-> Text (Syntax a))) + (lambda [input] + (#;Left message))) + +(def: #export (default value parser) + {#;doc "If the given parser fails, returns the default value."} + (All [a] (-> a (Syntax a) (Syntax a))) + (lambda [input] + (case (parser input) + (#;Left error) + (#;Right [input value]) + + (#;Right [input' output]) + (#;Right [input' output])))) + +(def: #export (on compiler meta) + (All [a] (-> Compiler (Lux a) (Syntax a))) + (lambda [input] + (case (meta compiler) + (#;Left error) + (#;Left error) + + (#;Right [_ value]) + (#;Right [input value]) + ))) + +(def: #export (local local-inputs syntax) + (All [a] (-> (List AST) (Syntax a) (Syntax a))) + (lambda [real-inputs] + (case (syntax local-inputs) + (#;Left error) + (#;Left error) + + (#;Right [unconsume-inputs value]) + (case unconsume-inputs + #;Nil + (#;Right [real-inputs value]) + + _ + (#;Left "Unconsumed inputs."))))) + +## [Syntax] +(def: #hidden text.join-with text;join-with) + +(macro: #export (syntax: tokens) + {#;doc (doc "A more advanced way to define macros than macro:." + "The inputs to the macro can be parsed in complex ways through the use of syntax parsers." + "The macro body is also (implicitly) run in the Monad<Lux>, to save some typing." + "Also, the compiler state can be accessed through the *compiler* binding." + (syntax: #export (object [#let [imports (class-imports *compiler*)]] + [#let [class-vars (list)]] + [super (opt (super-class-decl^ imports class-vars))] + [interfaces (tuple (some (super-class-decl^ imports class-vars)))] + [constructor-args (constructor-args^ imports class-vars)] + [methods (some (overriden-method-def^ imports))]) + (let [def-code ($_ Text/append "anon-class:" + (spaced (list (super-class-decl$ (;default object-super-class super)) + (with-brackets (spaced (map super-class-decl$ interfaces))) + (with-brackets (spaced (map constructor-arg$ constructor-args))) + (with-brackets (spaced (map (method-def$ id) methods))))))] + (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))))))} + (let [[exported? tokens] (case tokens + (^ (list& [_ (#;TagS ["" "export"])] tokens')) + [true tokens'] + + _ + [false tokens]) + ?parts (: (Maybe [Text (List AST) AST AST]) + (case tokens + (^ (list [_ (#;FormS (list& [_ (#;SymbolS ["" name])] args))] + body)) + (#;Some name args (` {}) body) + + (^ (list [_ (#;FormS (list& [_ (#;SymbolS ["" name])] args))] + meta-data + body)) + (#;Some name args meta-data body) + + _ + #;None))] + (case ?parts + (#;Some [name args meta body]) + (with-gensyms [g!tokens g!body g!msg] + (do Monad<Lux> + [vars+parsers (mapM Monad<Lux> + (: (-> AST (Lux [AST AST])) + (lambda [arg] + (case arg + (^ [_ (#;RecordS (list [var parser]))]) + (wrap [var parser]) + + [_ (#;SymbolS var-name)] + (wrap [(ast;symbol var-name) (` any)]) + + _ + (compiler;fail "Syntax pattern expects records or symbols.")))) + args) + #let [g!state (ast;symbol ["" "*compiler*"]) + g!end (ast;symbol ["" ""]) + error-msg (ast;text (Text/append "Wrong syntax for " name)) + export-ast (: (List AST) (if exported? (list (' #export)) (list)))]] + (wrap (list (` (macro: (~@ export-ast) ((~ (ast;symbol ["" name])) (~ g!tokens)) + (~ meta) + (lambda [(~ g!state)] + (;_lux_case (run (~ g!tokens) + (: (Syntax (Lux (List AST))) + (do Monad<Syntax> + [(~@ (join-pairs vars+parsers)) + (~ g!end) end] + ((~' wrap) (do Monad<Lux> + [] + (~ body)))))) + (#;Right [(~ g!tokens) (~ g!body)]) + ((~ g!body) (~ g!state)) + + (#;Left (~ g!msg)) + (#;Left (text.join-with ": " (list (~ error-msg) (~ g!msg)))))))))))) + + _ + (compiler;fail "Wrong syntax for syntax:")))) diff --git a/stdlib/source/lux/macro/syntax/common.lux b/stdlib/source/lux/macro/syntax/common.lux new file mode 100644 index 000000000..743768fe6 --- /dev/null +++ b/stdlib/source/lux/macro/syntax/common.lux @@ -0,0 +1,164 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monad) + (data (struct [list]) + text/format) + [compiler] + (macro [ast] + ["s" syntax #+ syntax: Syntax]))) + +## Exports +(type: #export Export-Level + #Exported + #Hidden) + +(def: #export export-level + (Syntax (Maybe Export-Level)) + (s;opt (s;alt (s;tag! ["" "export"]) + (s;tag! ["" "hidden"])))) + +(def: #export (gen-export-level ?el) + (-> (Maybe Export-Level) (List AST)) + (case ?el + #;None + (list) + + (#;Some #Exported) + (list (' #export)) + + (#;Some #Hidden) + (list (' #hidden)))) + +## Declarations +(type: #export Decl + {#decl-name Text + #decl-args (List Text)}) + +(def: #export decl + (s;either (s;seq s;local-symbol + (:: s;Monad<Syntax> wrap (list))) + (s;form (s;seq s;local-symbol + (s;many s;local-symbol))))) + +## Definitions +(type: #export Def-Syntax + {#def-name Text + #def-type (Maybe AST) + #def-value AST + #def-meta (List [Ident AST]) + #def-args (List Text) + }) + +(def: check^ + (Syntax [(Maybe AST) AST]) + (s;either (s;form (do s;Monad<Syntax> + [_ (s;symbol! ["lux" "_lux_:"]) + type s;any + value s;any] + (wrap [(#;Some type) value]))) + (s;seq (:: s;Monad<Syntax> wrap #;None) + s;any))) + +(def: _def-meta-tag^ + (Syntax Ident) + (s;tuple (s;seq s;text s;text))) + +(def: (_def-meta^ _) + (-> Top (Syntax (List [Ident AST]))) + (s;alt (s;tag! ["lux" "Nil"]) + (s;form (do s;Monad<Syntax> + [_ (s;tag! ["lux" "Cons"]) + [head tail] (s;seq (s;tuple (s;seq _def-meta-tag^ s;any)) + (_def-meta^ []))] + (wrap [head tail]))) + )) + +(def: (flat-list^ _) + (-> Top (Syntax (List AST))) + (s;either (do s;Monad<Syntax> + [_ (s;tag! ["lux" "Nil"])] + (wrap (list))) + (s;form (do s;Monad<Syntax> + [_ (s;tag! ["lux" "Cons"]) + [head tail] (s;tuple (s;seq s;any s;any)) + tail (s;local (list tail) (flat-list^ []))] + (wrap (#;Cons head tail)))))) + +(def: list-meta^ + (Syntax (List AST)) + (s;form (do s;Monad<Syntax> + [_ (s;tag! ["lux" "ListM"])] + (flat-list^ [])))) + +(def: text-meta^ + (Syntax Text) + (s;form (do s;Monad<Syntax> + [_ (s;tag! ["lux" "TextM"])] + s;text))) + +(def: (find-def-args meta-data) + (-> (List [Ident AST]) (List Text)) + (default (list) + (list;find (lambda [[tag value]] + (case tag + (^=> ["lux" "func-args"] + {(s;run (list value) list-meta^) + (#;Right [_ args])} + {(s;run args (s;some text-meta^)) + (#;Right [_ args])}) + (#;Some args) + + _ + #;None)) + meta-data))) + +(def: #export (def compiler) + (-> Compiler (Syntax Def-Syntax)) + (do s;Monad<Syntax> + [def-raw s;any + me-def-raw (s;on compiler + (compiler;macro-expand-all def-raw))] + (s;local me-def-raw + (s;form (do @ + [_ (s;symbol! ["lux" "_lux_def"]) + def-name s;local-symbol + [?def-type def-value] check^ + def-meta s;any + def-meta (s;local (list def-meta) + (_def-meta^ [])) + #let [def-args (find-def-args def-meta)]] + (wrap {#def-name def-name + #def-type ?def-type + #def-meta def-meta + #def-value def-value + #def-args def-args})))))) + +(def: #export (typed-de compiler) + (-> Compiler (Syntax Def-Syntax)) + (do s;Monad<Syntax> + [_def (def compiler) + _ (case (get@ #def-type _def) + (#;Some _) + (wrap []) + + #;None + (s;fail "Typed def must have a type!") + )] + (wrap _def))) + +(def: #export def-meta + (Syntax (List [Ident AST])) + (s;record (s;some (s;seq s;tag s;any)))) + +(def: #export typed-arg + (Syntax [Text AST]) + (s;record (s;seq s;local-symbol s;any))) + +(def: #export type-params + (Syntax (List Text)) + (s;tuple (s;some s;local-symbol))) diff --git a/stdlib/source/lux/macro/template.lux b/stdlib/source/lux/macro/template.lux new file mode 100644 index 000000000..0288f05cf --- /dev/null +++ b/stdlib/source/lux/macro/template.lux @@ -0,0 +1,54 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monad) + (data (struct [list "" Monad<List> Fold<List>] + [dict #+ Dict]) + [text]) + [compiler] + (macro [ast] + ["s" syntax #+ syntax: Syntax] + (syntax [common])))) + +## [Syntax] +(def: decl^ + (Syntax [Text (List Text)]) + (s;form (s;seq s;local-symbol (s;many s;local-symbol)))) + +(def: (prepare bindings template) + (-> (Dict Text AST) AST AST) + (case template + (^=> [_ (#;SymbolS "" name)] + {(dict;get name bindings) (#;Some found)}) + found + + (^template [<tag>] + [meta (<tag> parts)] + [meta (<tag> (map (prepare bindings ) parts))]) + ([#;FormS] + [#;TupleS]) + + + [meta (#;RecordS pairs)] + [meta (#;RecordS (map (lambda [[slot value]] + [(prepare bindings slot) + (prepare bindings value)]) + pairs))] + + _ + template + )) + +(syntax: #export (template: {_ex-lev common;export-level} {[name args] decl^} template) + (let [bindings (fold (lambda [arg bindings] + (dict;put arg (` ((~' ~) (~ (ast;symbol ["" arg])))) bindings)) + (: (Dict Text AST) (dict;new text;Hash<Text>)) + args)] + (wrap (list (` (syntax: (~@ (common;gen-export-level _ex-lev)) ((~ (ast;symbol ["" name])) + (~@ (map (|>. [""] ast;symbol) args))) + ((~' wrap) (list (` (~ (prepare bindings template))))))))) + )) diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux new file mode 100644 index 000000000..ffc13818f --- /dev/null +++ b/stdlib/source/lux/math.lux @@ -0,0 +1,158 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: {#;doc "Common numerical operations."} + lux + (lux (control monad) + (data (struct [list "" Fold<List>]) + [number "Int/" Number<Int>] + [product] + text/format) + host + [compiler] + (macro ["s" syntax #+ syntax: Syntax "Syntax/" Functor<Syntax>] + [ast]))) + +## [Values] +(do-template [<name> <value>] + [(def: #export <name> + Real + (_lux_proc ["jvm" <value>] []))] + + [e "getstatic:java.lang.Math:E"] + [pi "getstatic:java.lang.Math:PI"] + ) + +(def: #export tau Real 6.28318530717958647692) + +(do-template [<name> <method>] + [(def: #export (<name> n) + (-> Real Real) + (_lux_proc ["jvm" <method>] [n]))] + + [cos "invokestatic:java.lang.Math:cos:double"] + [sin "invokestatic:java.lang.Math:sin:double"] + [tan "invokestatic:java.lang.Math:tan:double"] + + [acos "invokestatic:java.lang.Math:acos:double"] + [asin "invokestatic:java.lang.Math:asin:double"] + [atan "invokestatic:java.lang.Math:atan:double"] + + [cosh "invokestatic:java.lang.Math:cosh:double"] + [sinh "invokestatic:java.lang.Math:sinh:double"] + [tanh "invokestatic:java.lang.Math:tanh:double"] + + [exp "invokestatic:java.lang.Math:exp:double"] + [log "invokestatic:java.lang.Math:log:double"] + + [cbrt "invokestatic:java.lang.Math:cbrt:double"] + [sqrt "invokestatic:java.lang.Math:sqrt:double"] + + [degrees "invokestatic:java.lang.Math:toDegrees:double"] + [radians "invokestatic:java.lang.Math:toRadians:double"] + ) + +(do-template [<name> <method>] + [(def: #export (<name> n) + (-> Real Real) + (_lux_proc ["jvm" <method>] [n]))] + + [ceil "invokestatic:java.lang.Math:ceil:double"] + [floor "invokestatic:java.lang.Math:floor:double"] + ) + +(def: #export (round n) + (-> Real Real) + (int-to-real (_lux_proc ["jvm" "invokestatic:java.lang.Math:round:double"] [n]))) + +(do-template [<name> <method>] + [(def: #export (<name> param subject) + (-> Real Real Real) + (_lux_proc ["jvm" <method>] [subject param]))] + + [atan2 "invokestatic:java.lang.Math:atan2:double,double"] + [pow "invokestatic:java.lang.Math:pow:double,double"] + ) + +(def: (gcd' a b) + (-> Int Int Int) + (case b + 0 a + _ (gcd' b (% b a)))) + +(def: #export (gcd a b) + {#;doc "Greatest Common Divisor."} + (-> Int Int Int) + (gcd' (Int/abs a) (Int/abs b))) + +(def: #export (lcm x y) + {#;doc "Least Common Multiple."} + (-> Int Int Int) + (case [x y] + (^or [_ 0] [0 _]) + 0 + + _ + (|> x (/ (gcd x y)) (* y) Int/abs) + )) + +## [Syntax] +(type: #rec Infix + (#Const AST) + (#Call (List AST)) + (#Infix Infix AST Infix)) + +(def: (infix^ _) + (-> Unit (Syntax Infix)) + ($_ s;alt + ($_ s;either + (Syntax/map ast;bool s;bool) + (Syntax/map ast;int s;int) + (Syntax/map ast;real s;real) + (Syntax/map ast;char s;char) + (Syntax/map ast;text s;text) + (Syntax/map ast;symbol s;symbol) + (Syntax/map ast;tag s;tag)) + (s;form (s;many s;any)) + (s;tuple (s;either (do s;Monad<Syntax> + [_ (s;tag! ["" "and"]) + init-subject (infix^ []) + init-op s;any + init-param (infix^ []) + steps (s;some (s;seq s;any (infix^ [])))] + (wrap (product;right (fold (lambda [[op param] [subject [_subject _op _param]]] + [param [(#Infix _subject _op _param) + (` and) + (#Infix subject op param)]]) + [init-param [init-subject init-op init-param]] + steps)))) + (do s;Monad<Syntax> + [_ (wrap []) + init-subject (infix^ []) + init-op s;any + init-param (infix^ []) + steps (s;some (s;seq s;any (infix^ [])))] + (wrap (fold (lambda [[op param] [_subject _op _param]] + [(#Infix _subject _op _param) op param]) + [init-subject init-op init-param] + steps))) + )) + )) + +(def: (infix-to-prefix infix) + (-> Infix AST) + (case infix + (#Const value) + value + + (#Call parts) + (ast;form parts) + + (#Infix left op right) + (` ((~ op) (~ (infix-to-prefix right)) (~ (infix-to-prefix left)))) + )) + +(syntax: #export (infix {expr (infix^ [])}) + (wrap (list (infix-to-prefix expr)))) diff --git a/stdlib/source/lux/math/complex.lux b/stdlib/source/lux/math/complex.lux new file mode 100644 index 000000000..eb7796bb2 --- /dev/null +++ b/stdlib/source/lux/math/complex.lux @@ -0,0 +1,291 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux [math] + (control eq + [ord] + number + codec + monad) + (data [number "r:" Number<Real> Codec<Text,Real>] + [text "Text/" Monoid<Text>] + error + maybe + (struct [list "List/" Monad<List>])) + [compiler] + (macro [ast] + ["s" syntax #+ syntax: Syntax]))) + +## Based on org.apache.commons.math4.complex.Complex + +(type: #export Complex + {#real Real + #imaginary Real}) + +(syntax: #export (complex real {?imaginary (s;opt s;any)}) + (wrap (list (` {#;;real (~ real) + #;;imaginary (~ (default (` 0.0) + ?imaginary))})))) + +(def: #export i Complex (complex 0.0 1.0)) + +(def: #export one Complex (complex 1.0 0.0)) + +(def: #export zero Complex (complex 0.0 0.0)) + +(def: #export (c= param input) + (-> Complex Complex Bool) + (and (=. (get@ #real param) + (get@ #real input)) + (=. (get@ #imaginary param) + (get@ #imaginary input)))) + +(do-template [<name> <op>] + [(def: #export (<name> param input) + (-> Complex Complex Complex) + {#real (<op> (get@ #real param) + (get@ #real input)) + #imaginary (<op> (get@ #imaginary param) + (get@ #imaginary input))})] + + [c+ +.] + [c- -.] + ) + +(struct: #export _ (Eq Complex) + (def: = c=)) + +(def: #export negate + (-> Complex Complex) + (|>. (update@ #real r:negate) + (update@ #imaginary r:negate))) + +(def: #export signum + (-> Complex Complex) + (|>. (update@ #real r:signum) + (update@ #imaginary r:signum))) + +(def: #export conjugate + (-> Complex Complex) + (update@ #imaginary r:negate)) + +(def: #export (c*' param input) + (-> Real Complex Complex) + {#real (*. param + (get@ #real input)) + #imaginary (*. param + (get@ #imaginary input))}) + +(def: #export (c* param input) + (-> Complex Complex Complex) + {#real (-. (*. (get@ #imaginary param) + (get@ #imaginary input)) + (*. (get@ #real param) + (get@ #real input))) + #imaginary (+. (*. (get@ #real param) + (get@ #imaginary input)) + (*. (get@ #imaginary param) + (get@ #real input)))}) + +(def: #export (c/ (^slots [#real #imaginary]) input) + (-> Complex Complex Complex) + (if (<. (r:abs imaginary) + (r:abs real)) + (let [quot (/. imaginary real) + denom (|> real (*. quot) (+. imaginary))] + {#real (|> (get@ #real input) (*. quot) (+. (get@ #imaginary input)) (/. denom)) + #imaginary (|> (get@ #imaginary input) (*. quot) (-. (get@ #real input)) (/. denom))}) + (let [quot (/. real imaginary) + denom (|> imaginary (*. quot) (+. real))] + {#real (|> (get@ #imaginary input) (*. quot) (+. (get@ #real input)) (/. denom)) + #imaginary (|> (get@ #imaginary input) (-. (*. quot (get@ #real input))) (/. denom))}))) + +(def: #export (c/' param (^slots [#real #imaginary])) + (-> Real Complex Complex) + {#real (/. param real) + #imaginary (/. param imaginary)}) + +(def: #export (cos (^slots [#real #imaginary])) + (-> Complex Complex) + {#real (*. (math;cosh imaginary) + (math;cos real)) + #imaginary (*. (math;sinh imaginary) + (r:negate (math;sin real)))}) + +(def: #export (cosh (^slots [#real #imaginary])) + (-> Complex Complex) + {#real (*. (math;cos imaginary) + (math;cosh real)) + #imaginary (*. (math;sin imaginary) + (math;sinh real))}) + +(def: #export (sin (^slots [#real #imaginary])) + (-> Complex Complex) + {#real (*. (math;cosh imaginary) + (math;sin real)) + #imaginary (*. (math;sinh imaginary) + (math;cos real))}) + +(def: #export (sinh (^slots [#real #imaginary])) + (-> Complex Complex) + {#real (*. (math;cos imaginary) + (math;sinh real)) + #imaginary (*. (math;sin imaginary) + (math;cosh real))}) + +(def: #export (tan (^slots [#real #imaginary])) + (-> Complex Complex) + (let [r2 (*. 2.0 real) + i2 (*. 2.0 imaginary) + d (+. (math;cos r2) (math;cosh i2))] + {#real (/. d (math;sin r2)) + #imaginary (/. d (math;sinh i2))})) + +(def: #export (tanh (^slots [#real #imaginary])) + (-> Complex Complex) + (let [r2 (*. 2.0 real) + i2 (*. 2.0 imaginary) + d (+. (math;cosh r2) (math;cos i2))] + {#real (/. d (math;sinh r2)) + #imaginary (/. d (math;sin i2))})) + +(def: #export (abs (^slots [#real #imaginary])) + (-> Complex Real) + (if (<. (r:abs imaginary) + (r:abs real)) + (if (=. 0.0 imaginary) + (r:abs real) + (let [q (/. imaginary real)] + (*. (math;sqrt (+. 1.0 (*. q q))) + (r:abs imaginary)))) + (if (=. 0.0 real) + (r:abs imaginary) + (let [q (/. real imaginary)] + (*. (math;sqrt (+. 1.0 (*. q q))) + (r:abs real)))) + )) + +(def: #export (exp (^slots [#real #imaginary])) + (-> Complex Complex) + (let [r-exp (math;exp real)] + {#real (*. r-exp (math;cos imaginary)) + #imaginary (*. r-exp (math;sin imaginary))})) + +(def: #export (log (^@ input (^slots [#real #imaginary]))) + (-> Complex Complex) + {#real (math;log (abs input)) + #imaginary (math;atan2 real imaginary)}) + +(do-template [<name> <type> <op>] + [(def: #export (<name> param input) + (-> <type> Complex Complex) + (|> input log (<op> param) exp))] + + [pow Complex c*] + [pow' Real c*'] + ) + +(def: (copy-sign sign magnitude) + (-> Real Real Real) + (*. (r:signum sign) magnitude)) + +(def: #export (sqrt (^@ input (^slots [#real #imaginary]))) + (-> Complex Complex) + (let [t (|> input abs (+. (r:abs real)) (/. 2.0) math;sqrt)] + (if (>=. 0.0 real) + {#real t + #imaginary (/. (*. 2.0 t) + imaginary)} + {#real (/. (*. 2.0 t) + (r:abs imaginary)) + #imaginary (*. t (copy-sign imaginary 1.0))}))) + +(def: #export (sqrt-1z input) + (-> Complex Complex) + (|> (complex 1.0) (c- (c* input input)) sqrt)) + +(def: #export (reciprocal (^slots [#real #imaginary])) + (-> Complex Complex) + (if (<. (r:abs imaginary) + (r:abs real)) + (let [q (/. imaginary real) + scale (/. (|> real (*. q) (+. imaginary)) + 1.0)] + {#real (*. q scale) + #imaginary (r:negate scale)}) + (let [q (/. real imaginary) + scale (/. (|> imaginary (*. q) (+. real)) + 1.0)] + {#real scale + #imaginary (|> scale r:negate (*. q))}))) + +(def: #export (acos input) + (-> Complex Complex) + (|> input + (c+ (|> input sqrt-1z (c* i))) + log + (c* (negate i)))) + +(def: #export (asin input) + (-> Complex Complex) + (|> input + sqrt-1z + (c+ (c* i input)) + log + (c* (negate i)))) + +(def: #export (atan input) + (-> Complex Complex) + (|> input + (c+ i) + (c/ (c- input i)) + log + (c* (c/ (complex 2.0) i)))) + +(def: #export (argument (^slots [#real #imaginary])) + (-> Complex Real) + (math;atan2 real imaginary)) + +(def: #export (nth-root nth input) + (-> Nat Complex (List Complex)) + (if (=+ +0 nth) + (list) + (let [r-nth (|> nth nat-to-int int-to-real) + nth-root-of-abs (math;pow (/. r-nth 1.0) + (abs input)) + nth-phi (|> input argument (/. r-nth)) + slice (|> math;pi (*. 2.0) (/. r-nth))] + (|> (list;range+ +0 (dec+ nth)) + (List/map (lambda [nth'] + (let [inner (|> nth' nat-to-int int-to-real + (*. slice) + (+. nth-phi)) + real (*. nth-root-of-abs + (math;cos inner)) + imaginary (*. nth-root-of-abs + (math;sin inner))] + {#real real + #imaginary imaginary}))))))) + +(struct: #export _ (Codec Text Complex) + (def: (encode (^slots [#real #imaginary])) + ($_ Text/append "(" (r:encode real) ", " (r:encode imaginary) ")")) + + (def: (decode input) + (case (do Monad<Maybe> + [input' (text;sub +1 (-+ +1 (text;size input)) input)] + (text;split-with "," input')) + #;None + (#;Left (Text/append "Wrong syntax for complex numbers: " input)) + + (#;Some [r' i']) + (do Monad<Error> + [r (r:decode (text;trim r')) + i (r:decode (text;trim i'))] + (wrap {#real r + #imaginary i})) + ))) diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux new file mode 100644 index 000000000..aee5674ad --- /dev/null +++ b/stdlib/source/lux/math/random.lux @@ -0,0 +1,283 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + [lux #- list] + (lux (control functor + applicative + monad + hash) + (data [bit] + [char] + [text "Text/" Monoid<Text>] + text/format + [product] + [number] + (struct [list "List/" Fold<List>] + ["A" array] + ["D" dict] + ["Q" queue] + ["S" set] + ["ST" stack] + ["V" vector])) + (math ["r" ratio] + ["c" complex]))) + +## [Exports] +(type: #export #rec PRNG + (-> Unit [PRNG Nat])) + +(type: #export (Random a) + (-> PRNG [PRNG a])) + +(struct: #export _ (Functor Random) + (def: (map f fa) + (lambda [state] + (let [[state' a] (fa state)] + [state' (f a)])))) + +(struct: #export _ (Applicative Random) + (def: functor Functor<Random>) + + (def: (wrap a) + (lambda [state] + [state a])) + + (def: (apply ff fa) + (lambda [state] + (let [[state' f] (ff state) + [state'' a] (fa state')] + [state'' (f a)])))) + +(struct: #export _ (Monad Random) + (def: applicative Applicative<Random>) + + (def: (join ffa) + (lambda [state] + (let [[state' fa] (ffa state)] + (fa state'))))) + +(def: #export nat + (Random Nat) + (lambda [prng] + (let [[prng left] (prng []) + [prng right] (prng [])] + [prng (++ (bit;<< +32 left) + right)]))) + +(def: #export int + (Random Int) + (lambda [prng] + (let [[prng left] (prng []) + [prng right] (prng [])] + [prng (nat-to-int (++ (bit;<< +32 left) + right))]))) + +(def: #export bool + (Random Bool) + (lambda [prng] + (let [[prng output] (prng [])] + [prng (|> output (bit;& +1) (=+ +1))]))) + +(def: (bits n) + (-> Nat (Random Nat)) + (lambda [prng] + (let [[prng output] (prng [])] + [prng (bit;>>> (-+ n +64) output)]))) + +(def: #export real + (Random Real) + (do Monad<Random> + [left (bits +26) + right (bits +27)] + (wrap (|> right + (++ (bit;<< +27 left)) + nat-to-int + int-to-real + (/. (|> +1 (bit;<< +53) nat-to-int int-to-real)))))) + +(def: #export frac + (Random Frac) + (:: Monad<Random> map real-to-frac real)) + +(def: #export char + (Random Char) + (do Monad<Random> + [base nat] + (wrap (char;char base)))) + +(def: #export (text' char-gen size) + (-> (Random Char) Nat (Random Text)) + (if (=+ +0 size) + (:: Monad<Random> wrap "") + (do Monad<Random> + [x char-gen + xs (text' char-gen (dec+ size))] + (wrap (Text/append (char;as-text x) xs))))) + +(def: #export (text size) + (-> Nat (Random Text)) + (text' char size)) + +(do-template [<name> <type> <ctor> <gen>] + [(def: #export <name> + (Random <type>) + (do Monad<Random> + [left <gen> + right <gen>] + (wrap (<ctor> left right))))] + + [ratio r;Ratio r;ratio int] + [complex c;Complex c;complex real] + ) + +(def: #export (seq left right) + (All [a b] (-> (Random a) (Random b) (Random [a b]))) + (do Monad<Random> + [=left left + =right right] + (wrap [=left =right]))) + +(def: #export (alt left right) + (All [a b] (-> (Random a) (Random b) (Random (| a b)))) + (do Monad<Random> + [? bool] + (if ? + (do @ + [=left left] + (wrap (+0 =left))) + (do @ + [=right right] + (wrap (+1 =right)))))) + +(def: #export (either left right) + (All [a] (-> (Random a) (Random a) (Random a))) + (do Monad<Random> + [? bool] + (if ? + left + right))) + +(def: #export (rec gen) + (All [a] (-> (-> (Random a) (Random a)) (Random a))) + (lambda [state] + (let [gen' (gen (rec gen))] + (gen' state)))) + +(def: #export (filter pred gen) + (All [a] (-> (-> a Bool) (Random a) (Random a))) + (do Monad<Random> + [sample gen] + (if (pred sample) + (wrap sample) + (filter pred gen)))) + +(do-template [<name> <type> <zero> <plus>] + [(def: #export (<name> size value-gen) + (All [a] (-> Nat (Random a) (Random (<type> a)))) + (if (>+ +0 size) + (do Monad<Random> + [x value-gen + xs (<name> (dec+ size) value-gen)] + (wrap (<plus> x xs))) + (:: Monad<Random> wrap <zero>)))] + + [list List (;list) #;Cons] + [vector V;Vector V;empty V;add] + ) + +(do-template [<name> <type> <ctor>] + [(def: #export (<name> size value-gen) + (All [a] (-> Nat (Random a) (Random (<type> a)))) + (do Monad<Random> + [values (list size value-gen)] + (wrap (|> values <ctor>))))] + + [array A;Array A;from-list] + [queue Q;Queue Q;from-list] + [stack ST;Stack (List/fold ST;push ST;empty)] + ) + +(def: #export (set a/Hash size value-gen) + (All [a] (-> (Hash a) Nat (Random a) (Random (S;Set a)))) + (if (>+ +0 size) + (do Monad<Random> + [xs (set a/Hash (dec+ size) value-gen)] + (loop [_ []] + (do @ + [x value-gen + #let [xs+ (S;add x xs)]] + (if (=+ size (S;size xs+)) + (wrap xs+) + (recur []))))) + (:: Monad<Random> wrap (S;new a/Hash)))) + +(def: #export (dict a/Hash size key-gen value-gen) + (All [k v] (-> (Hash k) Nat (Random k) (Random v) (Random (D;Dict k v)))) + (if (>+ +0 size) + (do Monad<Random> + [kv (dict a/Hash (dec+ size) key-gen value-gen)] + (loop [_ []] + (do @ + [k key-gen + v value-gen + #let [kv+ (D;put k v kv)]] + (if (=+ size (D;size kv+)) + (wrap kv+) + (recur []))))) + (:: Monad<Random> wrap (D;new a/Hash)))) + +(def: #export (run prng calc) + (All [a] (-> PRNG (Random a) [PRNG a])) + (calc prng)) + +## [PRNGs] +## PCG32 http://www.pcg-random.org/ +## Based on this Java implementation: https://github.com/alexeyr/pcg-java + +(def: pcg-32-magic-mult Nat +6364136223846793005) + +(def: #export (pcg-32 [inc seed]) + (-> [Nat Nat] PRNG) + (lambda [_] + (let [seed' (|> seed (*+ pcg-32-magic-mult) (++ inc)) + xor-shifted (|> seed (bit;>>> +18) (bit;^ seed) (bit;>>> +27)) + rot (|> seed (bit;>>> +59))] + [(pcg-32 [inc seed']) (bit;rotate-right rot xor-shifted)] + ))) + +## Xoroshiro128+ http://xoroshiro.di.unimi.it/ +(def: #export (xoroshiro-128+ [s0 s1]) + (-> [Nat Nat] PRNG) + (lambda [_] + (let [result (++ s0 s1) + s01 (bit;^ s0 s1) + s0' (|> (bit;rotate-left +55 s0) + (bit;^ s01) + (bit;^ (bit;<< +14 s01))) + s1' (bit;rotate-left +36 s01)] + [(xoroshiro-128+ [s0' s1']) result]) + )) + +## [Values] +(def: (swap from to vec) + (All [a] (-> Nat Nat (V;Vector a) (V;Vector a))) + (V;put to (default (undefined) + (V;at from vec)) + vec)) + +(def: #export (shuffle seed vector) + (All [a] (-> Nat (V;Vector a) (V;Vector a))) + (let [_size (V;size vector) + _shuffle (foldM Monad<Random> + (lambda [idx vec] + (do Monad<Random> + [rand nat] + (wrap (swap idx (%+ _size rand) vec)))) + vector + (list;range+ +0 (dec+ _size)))] + (|> _shuffle + (run (pcg-32 [+123 seed])) + product;right))) diff --git a/stdlib/source/lux/math/ratio.lux b/stdlib/source/lux/math/ratio.lux new file mode 100644 index 000000000..89d93aa5d --- /dev/null +++ b/stdlib/source/lux/math/ratio.lux @@ -0,0 +1,141 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux [math] + (control eq + [ord] + number + codec + monad) + (data [number "i:" Number<Int> Codec<Text,Int>] + [text "Text/" Monoid<Text>] + error) + [compiler] + (macro [ast] + ["s" syntax #+ syntax: Syntax]))) + +(type: #export Ratio + {#numerator Int + #denominator Int}) + +(def: #hidden (normalize (^slots [#numerator #denominator])) + (-> Ratio Ratio) + (let [common (math;gcd numerator denominator) + numerator (/ common numerator) + denominator (/ common denominator)] + {#numerator (if (and (< 0 numerator) + (< 0 denominator)) + (i:abs numerator) + numerator) + #denominator (i:abs denominator)})) + +(def: #export (r* param input) + (-> Ratio Ratio Ratio) + (normalize [(* (get@ #numerator param) + (get@ #numerator input)) + (* (get@ #denominator param) + (get@ #denominator input))])) + +(def: #export (r/ param input) + (-> Ratio Ratio Ratio) + (normalize [(* (get@ #denominator param) + (get@ #numerator input)) + (* (get@ #numerator param) + (get@ #denominator input))])) + +(def: #export (r+ param input) + (-> Ratio Ratio Ratio) + (normalize [(+ (* (get@ #denominator input) + (get@ #numerator param)) + (* (get@ #denominator param) + (get@ #numerator input))) + (* (get@ #denominator param) + (get@ #denominator input))])) + +(def: #export (r- param input) + (-> Ratio Ratio Ratio) + (normalize [(- (* (get@ #denominator input) + (get@ #numerator param)) + (* (get@ #denominator param) + (get@ #numerator input))) + (* (get@ #denominator param) + (get@ #denominator input))])) + +(def: #export (r% param input) + (-> Ratio Ratio Ratio) + (let [quot (/ (* (get@ #denominator input) + (get@ #numerator param)) + (* (get@ #denominator param) + (get@ #numerator input)))] + (r- (update@ #numerator (* quot) param) + input))) + +(def: #export (r= param input) + (-> Ratio Ratio Bool) + (and (= (get@ #numerator param) + (get@ #numerator input)) + (= (get@ #denominator param) + (get@ #denominator input)))) + +(do-template [<name> <op>] + [(def: #export (<name> param input) + (-> Ratio Ratio Bool) + (and (<op> (* (get@ #denominator input) + (get@ #numerator param)) + (* (get@ #denominator param) + (get@ #numerator input)))))] + + [r< <] + [r<= <=] + [r> >] + [r>= >=] + ) + +(struct: #export _ (Eq Ratio) + (def: = r=)) + +(struct: #export _ (ord;Ord Ratio) + (def: eq Eq<Ratio>) + (def: < r<) + (def: <= r<=) + (def: > r>) + (def: >= r>=)) + +(struct: #export _ (Number Ratio) + (def: ord Ord<Ratio>) + (def: + r+) + (def: - r-) + (def: * r*) + (def: / r/) + (def: % r%) + (def: negate (|>. (update@ #numerator i:negate) normalize)) + (def: abs (|>. (update@ #numerator i:abs) (update@ #denominator i:abs))) + (def: (signum x) + {#numerator (i:signum (get@ #numerator x)) + #denominator 1})) + +(def: separator Text ":") + +(struct: #export _ (Codec Text Ratio) + (def: (encode (^slots [#numerator #denominator])) + ($_ Text/append (i:encode numerator) separator (i:encode denominator))) + + (def: (decode input) + (case (text;split-with separator input) + (#;Some [num denom]) + (do Monad<Error> + [numerator (i:decode num) + denominator (i:decode denom)] + (wrap (normalize {#numerator numerator + #denominator denominator}))) + + #;None + (#;Left (Text/append "Invalid syntax for ratio: " input))))) + +(syntax: #export (ratio numerator denominator) + (wrap (list (` (normalize {#;;numerator (~ numerator) + #;;denominator (~ denominator)}))))) diff --git a/stdlib/source/lux/pipe.lux b/stdlib/source/lux/pipe.lux new file mode 100644 index 000000000..b1316f238 --- /dev/null +++ b/stdlib/source/lux/pipe.lux @@ -0,0 +1,147 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: {#;doc "Composable extensions to the piping macro |> that enhance it with various abilities."} + lux + (lux (control monad) + (data (struct [list #+ Monad<List> "" Fold<List> "List/" Monad<List>]) + maybe) + [compiler #+ with-gensyms Monad<Lux>] + (macro ["s" syntax #+ syntax: Syntax] + [ast]) + )) + +## [Syntax] +(def: body^ + (Syntax (List AST)) + (s;tuple (s;many s;any))) + +(syntax: #export (_> {tokens (s;at-least +2 s;any)}) + {#;doc (doc "Ignores the piped argument, and begins a new pipe." + (|> 20 + (* 3) + (+ 4) + (_> 0 inc)))} + (case (list;reverse tokens) + (^ (list& _ r-body)) + (wrap (list (` (|> (~@ (list;reverse r-body)))))) + + _ + (undefined))) + +(syntax: #export (@> {body body^} + prev) + {#;doc (doc "Gives the name '@' to the piped-argument, within the given expression." + (|> 5 + (@> [(+ @ @)])))} + (wrap (list (fold (lambda [next prev] + (` (let% [(~' @) (~ prev)] + (~ next)))) + prev + body)))) + +(syntax: #export (?> {branches (s;many (s;seq body^ body^))} + {?else (s;opt body^)} + prev) + {#;doc (doc "Branching for pipes." + "Both the tests and the bodies are piped-code, and must be given inside a tuple." + "If a last else-pipe isn't given, the piped-argument will be used instead." + (|> 5 + (?> [even?] [(* 2)] + [odd?] [(* 3)] + [(_> -1)])))} + (with-gensyms [g!temp] + (wrap (list (` (let% [(~ g!temp) (~ prev)] + (cond (~@ (do Monad<List> + [[test then] branches] + (list (` (|> (~ g!temp) (~@ test))) + (` (|> (~ g!temp) (~@ then)))))) + (~ (case ?else + (#;Some else) + (` (|> (~ g!temp) (~@ else))) + + _ + g!temp))))))))) + +(syntax: #export (!> {test body^} {then body^} prev) + {#;doc (doc + "Loops for pipes." + "Both the testing and calculating steps are pipes and must be given inside tuples." + (|> 1 + (!> [(< 10)] + [inc])))} + (with-gensyms [g!temp] + (wrap (list (` (loop [(~ g!temp) (~ prev)] + (if (|> (~ g!temp) (~@ test)) + ((~' recur) (|> (~ g!temp) (~@ then))) + (~ g!temp)))))))) + +(syntax: #export (%> monad {steps (s;some body^)} prev) + {#;doc (doc "Monadic pipes." + "Each steps in the monadic computation is a pipe and must be given inside a tuple." + (|> 5 + (%> Id/Monad + [(* 3)] + [(+ 4)] + [inc])))} + (with-gensyms [g!temp] + (case (list;reverse steps) + (^ (list& last-step prev-steps)) + (let [step-bindings (do Monad<List> + [step (list;reverse prev-steps)] + (list g!temp (` (|> (~ g!temp) (~@ step)))))] + (wrap (list (` (do (~ monad) + [(~ g!temp) (~ prev) + (~@ step-bindings)] + (|> (~ g!temp) (~@ last-step))))))) + + _ + (wrap (list prev))))) + +(syntax: #export (~> {body body^} prev) + {#;doc (doc "Non-updating pipes." + "Will generate piped computations, but their results won't be used in the larger scope." + (|> 5 + (~> [int-to-nat %n log!]) + (* 10)))} + (do @ + [g!temp (compiler;gensym "")] + (wrap (list (` (let [(~ g!temp) (~ prev)] + (exec (|> (~ g!temp) (~@ body)) + (~ g!temp)))))))) + +(syntax: #export (&> {paths (s;many body^)} prev) + {#;doc (doc "Parallel branching for pipes." + "Allows to run multiple pipelines for a value and gives you a tuple of the outputs." + (|> 5 + (&> [(* 10)] + [dec (/ 2)] + [Int/encode])) + "Will become: [50 2 \"5\"]")} + (do @ + [g!temp (compiler;gensym "")] + (wrap (list (` (let [(~ g!temp) (~ prev)] + [(~@ (List/map (lambda [body] (` (|> (~ g!temp) (~@ body)))) + paths))])))))) + +(syntax: #export (case> {branches (s;many (s;seq s;any s;any))} prev) + {#;doc (doc "Pattern-matching for pipes." + "The bodies of each branch are NOT pipes; just regular values." + (|> 5 + (case> 0 "zero" + 1 "one" + 2 "two" + 3 "three" + 4 "four" + 5 "five" + 6 "six" + 7 "seven" + 8 "eight" + 9 "nine" + _ "???")))} + (let [(^open "List/") Monad<List>] + (wrap (list (` (case (~ prev) + (~@ (List/join (List/map (lambda [[pattern body]] (list pattern body)) + branches))))))))) diff --git a/stdlib/source/lux/regex.lux b/stdlib/source/lux/regex.lux new file mode 100644 index 000000000..1d98d6bf5 --- /dev/null +++ b/stdlib/source/lux/regex.lux @@ -0,0 +1,432 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monad) + (data [char] + [text] + text/format + [number "Int/" Codec<Text,Int>] + [product] + (struct [list "" Fold<List> "List/" Monad<List>])) + [compiler #- run] + (macro [ast] + [syntax #+ syntax:]) + ["&" lexer #+ Lexer Monad<Lexer>])) + +## [Utils] +(def: #hidden (->Text lexer^) + (-> (Lexer Char) (Lexer Text)) + (do Monad<Lexer> + [output lexer^] + (wrap (char;as-text output)))) + +(def: regex-char^ + (Lexer Char) + (&;none-of "\\.|&()[]{}")) + +(def: escaped-char^ + (Lexer Char) + (do Monad<Lexer> + [? (&;opt (&;this-char #"\\")) + char (case ? + (#;Some _) &;any + #;None regex-char^)] + (wrap char))) + +(def: (local^ state lexer) + (All [a] (-> Text (Lexer a) (Lexer a))) + (lambda [old-state] + (case (lexer state) + (#;Left error) + (#;Left error) + + (#;Right [_ value]) + (#;Right [old-state value])))) + +(def: #hidden (refine^ refinement^ base^) + (All [a] (-> (Lexer a) (Lexer Text) (Lexer Text))) + (do Monad<Lexer> + [output base^ + _ (local^ output refinement^)] + (wrap output))) + +(def: #hidden word^ + (Lexer Char) + (&;either &;alpha-num + (&;this-char #"_"))) + +(def: #hidden (join-text^ part^) + (-> (Lexer (List Text)) (Lexer Text)) + (do Monad<Lexer> + [parts part^] + (wrap (text;join-with "" parts)))) + +(def: identifier-char^ + (Lexer Char) + (&;none-of "[]{}()s\"#;<>")) + +(def: identifier-part^ + (Lexer Text) + (do Monad<Lexer> + [head (refine^ (&;not &;digit) + (->Text identifier-char^)) + tail (&;some' identifier-char^)] + (wrap (format head tail)))) + +(def: (identifier^ current-module) + (-> Text (Lexer Ident)) + (do Monad<Lexer> + [] + ($_ &;either + (&;seq (wrap current-module) (&;_& (&;this ";;") identifier-part^)) + (&;seq identifier-part^ (&;_& (&;this ";") identifier-part^)) + (&;seq (wrap "lux") (&;_& (&;this ";") identifier-part^)) + (&;seq (wrap "") identifier-part^)))) + +(def: (re-var^ current-module) + (-> Text (Lexer AST)) + (do Monad<Lexer> + [ident (&;enclosed ["\\@<" ">"] (identifier^ current-module))] + (wrap (` (: (Lexer Text) (~ (ast;symbol ident))))))) + +(def: re-char-range^ + (Lexer AST) + (do Monad<Lexer> + [from regex-char^ + _ (&;this-char #"-") + to regex-char^] + (wrap (` (&;char-range (~ (ast;char from)) (~ (ast;char to))))))) + +(def: re-char^ + (Lexer AST) + (do Monad<Lexer> + [char escaped-char^] + (wrap (` (&;this-char (~ (ast;char char))))))) + +(def: re-char+^ + (Lexer AST) + (do Monad<Lexer> + [base re-char^] + (wrap (` (->Text (~ base)))))) + +(def: re-char-options^ + (Lexer AST) + (do Monad<Lexer> + [options (&;many' escaped-char^)] + (wrap (` (&;one-of (~ (ast;text options))))))) + +(def: re-user-class^' + (Lexer AST) + (do Monad<Lexer> + [negate? (&;opt (&;this-char #"^")) + parts (&;many ($_ &;either + re-char-range^ + re-char-options^))] + (wrap (case negate? + (#;Some _) (` (->Text (&;not ($_ &;either (~@ parts))))) + #;None (` (->Text ($_ &;either (~@ parts)))))))) + +(def: re-user-class^ + (Lexer AST) + (do Monad<Lexer> + [_ (wrap []) + init re-user-class^' + rest (&;some (&;_& (&;this "&&") (&;enclosed ["[" "]"] re-user-class^')))] + (wrap (fold (lambda [refinement base] + (` (refine^ (~ refinement) (~ base)))) + init + rest)))) + +(def: #hidden blank^ + (Lexer Char) + (&;one-of " \t")) + +(def: #hidden ascii^ + (Lexer Char) + (&;char-range #"\u0000" #"\u007F")) + +(def: #hidden control^ + (Lexer Char) + (&;either (&;char-range #"\u0000" #"\u001F") + (&;this-char #"\u007F"))) + +(def: #hidden punct^ + (Lexer Char) + (&;one-of "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~")) + +(def: #hidden graph^ + (Lexer Char) + (&;either punct^ &;alpha-num)) + +(def: #hidden print^ + (Lexer Char) + (&;either graph^ + (&;this-char #"\u0020"))) + +(def: re-system-class^ + (Lexer AST) + (do Monad<Lexer> + [] + ($_ &;either + (&;_& (&;this-char #".") (wrap (` (->Text &;any)))) + (&;_& (&;this "\\d") (wrap (` (->Text &;digit)))) + (&;_& (&;this "\\D") (wrap (` (->Text (&;not &;digit))))) + (&;_& (&;this "\\s") (wrap (` (->Text &;space)))) + (&;_& (&;this "\\S") (wrap (` (->Text (&;not &;space))))) + (&;_& (&;this "\\w") (wrap (` (->Text word^)))) + (&;_& (&;this "\\W") (wrap (` (->Text (&;not word^))))) + (&;_& (&;this "\\d") (wrap (` (->Text &;digit)))) + + (&;_& (&;this "\\p{Lower}") (wrap (` (->Text &;lower)))) + (&;_& (&;this "\\p{Upper}") (wrap (` (->Text &;upper)))) + (&;_& (&;this "\\p{Alpha}") (wrap (` (->Text &;alpha)))) + (&;_& (&;this "\\p{Digit}") (wrap (` (->Text &;digit)))) + (&;_& (&;this "\\p{Alnum}") (wrap (` (->Text &;alpha-num)))) + (&;_& (&;this "\\p{Space}") (wrap (` (->Text &;space)))) + (&;_& (&;this "\\p{HexDigit}") (wrap (` (->Text &;hex-digit)))) + (&;_& (&;this "\\p{OctDigit}") (wrap (` (->Text &;oct-digit)))) + (&;_& (&;this "\\p{Blank}") (wrap (` (->Text blank^)))) + (&;_& (&;this "\\p{ASCII}") (wrap (` (->Text ascii^)))) + (&;_& (&;this "\\p{Contrl}") (wrap (` (->Text control^)))) + (&;_& (&;this "\\p{Punct}") (wrap (` (->Text punct^)))) + (&;_& (&;this "\\p{Graph}") (wrap (` (->Text graph^)))) + (&;_& (&;this "\\p{Print}") (wrap (` (->Text print^)))) + ))) + +(def: re-class^ + (Lexer AST) + (&;either re-system-class^ + (&;enclosed ["[" "]"] re-user-class^))) + +(def: int^ + (Lexer Int) + (&;codec number;Codec<Text,Int> (&;many' &;digit))) + +(def: re-back-reference^ + (Lexer AST) + (&;either (do Monad<Lexer> + [_ (&;this-char #"\\") + id int^] + (wrap (` (&;this (~ (ast;symbol ["" (Int/encode id)])))))) + (do Monad<Lexer> + [_ (&;this "\\k<") + captured-name identifier-part^ + _ (&;this ">")] + (wrap (` (&;this (~ (ast;symbol ["" captured-name])))))))) + +(def: (re-simple^ current-module) + (-> Text (Lexer AST)) + ($_ &;either + re-class^ + (re-var^ current-module) + re-back-reference^ + re-char+^ + )) + +(def: (re-simple-quantified^ current-module) + (-> Text (Lexer AST)) + (do Monad<Lexer> + [base (re-simple^ current-module) + quantifier (&;one-of "?*+")] + (case quantifier + #"?" + (wrap (` (&;default "" (~ base)))) + + #"*" + (wrap (` (join-text^ (&;some (~ base))))) + + _ + (wrap (` (join-text^ (&;many (~ base))))) + ))) + +(def: (re-counted-quantified^ current-module) + (-> Text (Lexer AST)) + (do Monad<Lexer> + [base (re-simple^ current-module)] + (&;enclosed ["{" "}"] + ($_ &;either + (do @ + [[from to] (&;seq int^ (&;_& (&;this-char #",") int^))] + (wrap (` (join-text^ (&;between (~ (ast;nat (int-to-nat from))) + (~ (ast;nat (int-to-nat to))) + (~ base)))))) + (do @ + [limit (&;_& (&;this-char #",") int^)] + (wrap (` (join-text^ (&;at-most (~ (ast;nat (int-to-nat limit))) (~ base)))))) + (do @ + [limit (&;&_ int^ (&;this-char #","))] + (wrap (` (join-text^ (&;at-least (~ (ast;nat (int-to-nat limit))) (~ base)))))) + (do @ + [limit int^] + (wrap (` (join-text^ (&;exactly (~ (ast;nat (int-to-nat limit))) (~ base)))))))))) + +(def: (re-quantified^ current-module) + (-> Text (Lexer AST)) + (&;either (re-simple-quantified^ current-module) + (re-counted-quantified^ current-module))) + +(def: (re-complex^ current-module) + (-> Text (Lexer AST)) + ($_ &;either + (re-quantified^ current-module) + (re-simple^ current-module))) + +(def: #hidden _Text/append_ + (-> Text Text Text) + (:: text;Monoid<Text> append)) + +(type: Re-Group + #Non-Capturing + (#Capturing [(Maybe Text) Nat])) + +(def: (re-sequential^ capturing? re-scoped^ current-module) + (-> Bool + (-> Text (Lexer [Re-Group AST])) + Text + (Lexer [Nat AST])) + (do Monad<Lexer> + [parts (&;many (&;alt (re-complex^ current-module) + (re-scoped^ current-module))) + #let [g!total (ast;symbol ["" "0total"]) + g!temp (ast;symbol ["" "0temp"]) + [_ names steps] (fold (: (-> (Either AST [Re-Group AST]) + [Int (List AST) (List (List AST))] + [Int (List AST) (List (List AST))]) + (lambda [part [idx names steps]] + (case part + (^or (#;Left complex) (#;Right [#Non-Capturing complex])) + [idx + names + (list& (list g!temp complex + (' #let) (` [(~ g!total) (_Text/append_ (~ g!total) (~ g!temp))])) + steps)] + + (#;Right [(#Capturing [?name num-captures]) scoped]) + (let [[idx! name!] (case ?name + (#;Some _name) + [idx (ast;symbol ["" _name])] + + #;None + [(inc idx) (ast;symbol ["" (Int/encode idx)])]) + access (if (>+ +0 num-captures) + (` (product;left (~ name!))) + name!)] + [idx! + (list& name! names) + (list& (list name! scoped + (' #let) (` [(~ g!total) (_Text/append_ (~ g!total) (~ access))])) + steps)]) + ))) + [0 + (: (List AST) (list)) + (: (List (List AST)) (list))] + parts)]] + (wrap [(if capturing? + (list;size names) + +0) + (` (do Monad<Lexer> + [(~ (' #let)) [(~ g!total) ""] + (~@ (|> steps list;reverse List/join))] + ((~ (' wrap)) [(~ g!total) (~@ (list;reverse names))])))]) + )) + +(def: #hidden (unflatten^ lexer) + (-> (Lexer Text) (Lexer [Text Unit])) + (&;seq lexer (:: Monad<Lexer> wrap []))) + +(def: #hidden (|||^ left right) + (All [l r] (-> (Lexer [Text l]) (Lexer [Text r]) (Lexer [Text (| l r)]))) + (lambda [input] + (case (left input) + (#;Right [input' [lt lv]]) + (#;Right [input' [lt (+0 lv)]]) + + (#;Left _) + (case (right input) + (#;Right [input' [rt rv]]) + (#;Right [input' [rt (+1 rv)]]) + + (#;Left error) + (#;Left error))))) + +(def: #hidden (|||_^ left right) + (All [l r] (-> (Lexer [Text l]) (Lexer [Text r]) (Lexer Text))) + (lambda [input] + (case (left input) + (#;Right [input' [lt lv]]) + (#;Right [input' lt]) + + (#;Left _) + (case (right input) + (#;Right [input' [rt rv]]) + (#;Right [input' rt]) + + (#;Left error) + (#;Left error))))) + +(def: (prep-alternative [num-captures alt]) + (-> [Nat AST] AST) + (if (>+ +0 num-captures) + alt + (` (unflatten^ (~ alt))))) + +(def: (re-alternative^ capturing? re-scoped^ current-module) + (-> Bool + (-> Text (Lexer [Re-Group AST])) + Text + (Lexer [Nat AST])) + (do Monad<Lexer> + [#let [sub^ (re-sequential^ capturing? re-scoped^ current-module)] + head sub^ + tail (&;some (&;_& (&;this-char #"|") sub^)) + #let [g!op (if capturing? + (` |||^) + (` |||_^))]] + (if (list;empty? tail) + (wrap head) + (wrap [(fold max+ (product;left head) (List/map product;left tail)) + (` ($_ (~ g!op) (~ (prep-alternative head)) (~@ (List/map prep-alternative tail))))])))) + +(def: (re-scoped^ current-module) + (-> Text (Lexer [Re-Group AST])) + ($_ &;either + (do Monad<Lexer> + [_ (&;this "(?:") + [_ scoped] (re-alternative^ false re-scoped^ current-module) + _ (&;this-char #")")] + (wrap [#Non-Capturing scoped])) + (do Monad<Lexer> + [complex (re-complex^ current-module)] + (wrap [#Non-Capturing complex])) + (do Monad<Lexer> + [_ (&;this "(?<") + captured-name identifier-part^ + _ (&;this ">") + [num-captures pattern] (re-alternative^ true re-scoped^ current-module) + _ (&;this-char #")")] + (wrap [(#Capturing [(#;Some captured-name) num-captures]) pattern])) + (do Monad<Lexer> + [_ (&;this-char #"(") + [num-captures pattern] (re-alternative^ true re-scoped^ current-module) + _ (&;this-char #")")] + (wrap [(#Capturing [#;None num-captures]) pattern])))) + +(def: (regex^ current-module) + (-> Text (Lexer AST)) + (:: Monad<Lexer> map product;right (re-alternative^ true re-scoped^ current-module))) + +## [Syntax] +(syntax: #export (regex {pattern syntax;text}) + (do @ + [current-module compiler;current-module-name] + (case (&;run (&;&_ (regex^ current-module) &;end) pattern) + (#;Left error) + (compiler;fail error) + + (#;Right regex) + (wrap (list regex)) + ))) diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux new file mode 100644 index 000000000..eba8034f9 --- /dev/null +++ b/stdlib/source/lux/test.lux @@ -0,0 +1,330 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux [compiler #+ Monad<Lux> with-gensyms] + (macro ["s" syntax #+ syntax: Syntax] + [ast]) + (control functor + applicative + monad) + (concurrency [promise #* "Promise/" Monad<Promise>]) + (data (struct [list "List/" Monad<List>]) + [product] + [text] + text/format + [error #* "Error/" Monad<Error>]) + (codata [io #- run]) + (math ["R" random]) + [host #- try])) + +## [Host] +(jvm-import java.lang.System + (#static exit [int] #io void) + (#static currentTimeMillis [] #io long)) + +(def: #hidden exit + (IO Unit) + (System.exit 0)) + +## [Types] +(type: #export (Test a) + (Promise (Error a))) + +## [Structs] +(struct: #export _ (Functor Test) + (def: (map f fa) + (Promise/map (Error/map f) fa))) + +(struct: #export _ (Applicative Test) + (def: functor Functor<Test>) + + (def: (wrap a) + (Promise/wrap (#;Right a))) + + (def: (apply ff fa) + (do Monad<Promise> + [f' ff + a' fa] + (case [f' a'] + [(#;Right f) (#;Right a)] + (wrap (#;Right (f a))) + + (^or [(#;Left msg) _] [_ (#;Left msg)]) + (wrap (#;Left msg)))) + )) + +(struct: #export _ (Monad Test) + (def: applicative Applicative<Test>) + + (def: (join mma) + (Promise/join (Promise/map (lambda [mma'] + (case mma' + (#;Left msg) + (Promise/wrap (#;Left msg)) + + (#;Right ma) + ma)) + mma))) + ) + +## [Values] +(def: #export (fail message) + (All [a] (-> Text (Test a))) + (:: Monad<Promise> wrap (#;Left message))) + +(def: #export (assert message test) + (-> Text Bool (Test Unit)) + (if test + (:: Monad<Test> wrap []) + (fail message))) + +(def: #export (from-promise promise) + (All [a] (-> (Promise a) (Test a))) + (do Monad<Promise> + [output promise] + (wrap (#;Right output)))) + +(def: #hidden (run' tests) + (-> (List [Text (IO (Test Unit)) Text]) (Promise Unit)) + (do Monad<Promise> + [printings (mapM @ + (: (-> [Text (IO (Test Unit)) Text] (Promise Unit)) + (lambda [[module test description]] + (do @ + [#let [pre (io;run (System.currentTimeMillis []))] + outcome (io;run test) + #let [post (io;run (System.currentTimeMillis []))]] + (case outcome + (#;Left error) + (wrap (log! (format "Error: " (:: text;Codec<Text,Text> encode description) " @ " module "\n" error "\n\n"))) + + _ + (exec (log! (format "Success: " (:: text;Codec<Text,Text> encode description) " @ " module + " in " (%i (- pre post)) "ms")) + (wrap [])))))) + tests)] + (wrap []))) + +(def: pcg-32-magic-inc Nat +12345) + +(type: #export Seed Nat) + +(def: #export (try seed random-test) + (-> Seed (R;Random (Test Unit)) (Test Seed)) + (let [[prng [new-seed test]] (R;run (R;pcg-32 [pcg-32-magic-inc seed]) + (do R;Monad<Random> + [test random-test + next-seed R;nat] + (wrap [next-seed test])))] + (do Monad<Test> + [_ test] + (wrap new-seed)))) + +(def: (repeat' seed times random-test) + (-> Seed Nat (R;Random (Test Unit)) (Test Seed)) + (case times + +0 + (fail "Can't try a test 0 times.") + + +1 + (try seed random-test) + + _ + (do Monad<Promise> + [output (try seed random-test)] + (case output + (#;Left error) + (fail (format "Test failed with this seed: " (%n seed) "\n" error)) + + (#;Right seed') + (repeat' seed' (dec+ times) random-test))))) + +(def: #export (repeat times random-test) + (-> Nat (R;Random (Test Unit)) (Test Unit)) + (do Monad<Test> + [_ (repeat' (int-to-nat (io;run (System.currentTimeMillis []))) + times + random-test)] + (wrap []))) + +## [Syntax] +(type: Property-Test + {#seed (Maybe (Either Nat Ident)) + #bindings (List [AST AST]) + #body AST}) + +(type: Test-Kind + (#Property Property-Test) + (#Simple AST)) + +(def: propery-test^ + (Syntax Property-Test) + ($_ s;seq + (s;opt (s;alt s;nat + s;symbol)) + (s;tuple (s;some (s;seq s;any s;any))) + s;any)) + +(def: test^ + (Syntax Test-Kind) + (s;alt propery-test^ + s;any)) + +(def: (pair-to-list [x y]) + (All [a] (-> [a a] (List a))) + (list x y)) + +(syntax: #export (test: description {body test^}) + {#;doc (doc "Macro for definint tests." + (test: "lux/pipe exports" + (all (match 1 (|> 20 + (* 3) + (+ 4) + (_> 0 inc))) + (match 10 (|> 5 + (@> (+ @ @)))) + (match 15 (|> 5 + (?> [even?] [(* 2)] + [odd?] [(* 3)] + [(_> -1)]))) + )))} + (let [body (case body + (#Property seed bindings body) + (let [seed' (case seed + #;None + (' +100) + + (#;Some (#;Left value)) + (ast;nat value) + + (#;Some (#;Right var)) + (ast;symbol var)) + bindings' (|> bindings (List/map pair-to-list) List/join)] + (` (repeat (~ seed') + (do R;Monad<Random> + [(~@ bindings')] + ((~' wrap) (~ body)))))) + + (#Simple body) + body)] + (with-gensyms [g!test] + (wrap (list (` (def: #export (~ g!test) + {#;;test (#;TextM (~ description))} + (IO (Test Unit)) + (io (~ body))))))))) + +(def: (exported-tests module-name) + (-> Text (Lux (List [Text Text Text]))) + (do Monad<Lux> + [defs (compiler;exports module-name)] + (wrap (|> defs + (List/map (lambda [[def-name [_ def-anns _]]] + (case (compiler;get-text-ann (ident-for #;;test) def-anns) + (#;Some description) + [true module-name def-name description] + + _ + [false module-name def-name ""]))) + (list;filter product;left) + (List/map product;right))))) + +(syntax: #export (match pattern expression) + {#;doc (doc "Runs an expression and pattern-matches against it using the given pattern." + "If the pattern-matching succeeds, the test succeeds." + (match 15 (|> 5 + (?> [even?] [(* 2)] + [odd?] [(* 3)]))))} + (with-gensyms [g!_] + (wrap (list (` (: (Test Unit) + (case (~ expression) + (~ pattern) + (~' (:: Monad<Test> wrap [])) + + (~ g!_) + (fail (~ (ast;text (format "Pattern was not matched: " (ast;ast-to-text pattern) + "\n\n" "From expression: " (ast;ast-to-text expression)))))))))))) + +(def: #hidden (should-pass' veredict expr-repr) + (All [a] (-> (Error a) Text (Test a))) + (case veredict + (#;Left message) (fail (format "'" message "' @ " expr-repr)) + (#;Right value) (:: Monad<Test> wrap value))) + +(def: #hidden (should-fail' veredict expr-repr) + (All [a] (-> (Error a) Text (Test Unit))) + (case veredict + (#;Left message) (:: Monad<Test> wrap []) + (#;Right value) (fail (format "Should have failed: " expr-repr)))) + +(do-template [<macro-name> <func-name> <doc>] + [(syntax: #export (<macro-name> expr) + {#;doc <doc>} + (wrap (list (` (<func-name> (~ expr) (~ (ast;text (ast;ast-to-text expr))))))))] + + [should-pass should-pass' "Verifies that a (Error a) computation succeeds/passes."] + [should-fail should-fail' "Verifies that a (Error a) computation fails."] + ) + +(syntax: #export (match+ pattern source) + {#;doc (doc "Same as \"match\", but the expression/source is expected to be of type (Test a)." + "That is, it's asynchronous and it may fail." + "If, however, it succeeds, it's value will be pattern-matched against." + (match+ 5 (commit (do Monad<STM> + [_ (write 5 _var) + value (read _var)] + (wrap (#;Right value))))))} + (with-gensyms [g!temp] + (wrap (list (` (: (Test Unit) + (do Monad<Test> + [(~ g!temp) (~ source)] + (match (~ pattern) (~ g!temp))))))))) + +(syntax: #export (run) + {#;doc (doc "Runs all the tests defined on the current module, and in all imported modules." + (run))} + (with-gensyms [g!_] + (do @ + [current-module compiler;current-module-name + modules (compiler;imported-modules current-module) + tests (: (Lux (List [Text Text Text])) + (:: @ map List/join (mapM @ exported-tests (#;Cons current-module modules)))) + #let [tests+ (List/map (lambda [[module-name test desc]] + (` [(~ (ast;text module-name)) (~ (ast;symbol [module-name test])) (~ (ast;text desc))])) + tests) + groups (list;split-all (|> (list;size tests+) (/+ concurrency-level) (++ +1) (min+ +16)) + tests+)]] + (wrap (list (` (: (IO Unit) + (io (exec (do Monad<Promise> + [(~@ (List/join (List/map (lambda [group] + (list g!_ (` (run' (list (~@ group)))))) + groups)))] + (exec (log! "Test-suite finished!") + (future exit))) + []))))))))) + +(syntax: #export (all {tests (s;some s;any)}) + {#;doc (doc "Given a sequence of tests, runs them all sequentially, and succeeds if the all succeed." + (test: "lux/pipe exports" + (all (match 1 (|> 20 + (* 3) + (+ 4) + (_> 0 inc))) + (match 10 (|> 5 + (@> (+ @ @)))) + (match 15 (|> 5 + (?> [even?] [(* 2)] + [odd?] [(* 3)] + [(_> -1)]))) + )))} + (with-gensyms [g!_] + (let [pairs (|> tests + (List/map (: (-> AST (List AST)) (lambda [test] (list g!_ test)))) + List/join)] + (wrap (list (` (: (Test Unit) + (do Monad<Test> + [(~@ pairs)] + ((~' wrap) []))))))))) diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux new file mode 100644 index 000000000..4a84582c4 --- /dev/null +++ b/stdlib/source/lux/type.lux @@ -0,0 +1,275 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control eq + monad) + (data [text "Text/" Monoid<Text> Eq<Text>] + [number "Nat/" Codec<Text,Nat>] + maybe + (struct [list #+ "List/" Monad<List> Monoid<List> Fold<List>])) + (macro [ast]) + )) + +## [Utils] +(def: (beta-reduce env type) + (-> (List Type) Type Type) + (case type + (#;HostT name params) + (#;HostT name (List/map (beta-reduce env) params)) + + (^template [<tag>] + (<tag> left right) + (<tag> (beta-reduce env left) (beta-reduce env right))) + ([#;SumT] [#;ProdT]) + + (^template [<tag>] + (<tag> left right) + (<tag> (beta-reduce env left) (beta-reduce env right))) + ([#;LambdaT] + [#;AppT]) + + (^template [<tag>] + (<tag> old-env def) + (case old-env + #;Nil + (<tag> env def) + + _ + type)) + ([#;UnivQ] + [#;ExQ]) + + (#;BoundT idx) + (default type (list;at idx env)) + + (#;NamedT name type) + (beta-reduce env type) + + _ + type + )) + +## [Structures] +(struct: #export _ (Eq Type) + (def: (= x y) + (case [x y] + [(#;HostT xname xparams) (#;HostT yname yparams)] + (and (Text/= xname yname) + (=+ (list;size yparams) (list;size xparams)) + (List/fold (lambda [[x y] prev] (and prev (= x y))) + true + (list;zip2 xparams yparams))) + + (^template [<tag>] + [<tag> <tag>] + true) + ([#;VoidT] [#;UnitT]) + + (^template [<tag>] + [(<tag> xid) (<tag> yid)] + (=+ yid xid)) + ([#;VarT] [#;ExT] [#;BoundT]) + + (^or [(#;LambdaT xleft xright) (#;LambdaT yleft yright)] + [(#;AppT xleft xright) (#;AppT yleft yright)]) + (and (= xleft yleft) + (= xright yright)) + + [(#;NamedT [xmodule xname] xtype) (#;NamedT [ymodule yname] ytype)] + (and (Text/= xmodule ymodule) + (Text/= xname yname) + (= xtype ytype)) + + (^template [<tag>] + [(<tag> xL xR) (<tag> yL yR)] + (and (= xL yL) (= xR yR))) + ([#;SumT] [#;ProdT]) + + (^or [(#;UnivQ xenv xbody) (#;UnivQ yenv ybody)] + [(#;ExQ xenv xbody) (#;ExQ yenv ybody)]) + (and (=+ (list;size yenv) (list;size xenv)) + (= xbody ybody) + (List/fold (lambda [[x y] prev] (and prev (= x y))) + true + (list;zip2 xenv yenv))) + + _ + false + ))) + +## [Values] +(def: #export (flatten-function type) + (-> Type [(List Type) Type]) + (case type + (#;LambdaT in out') + (let [[ins out] (flatten-function out')] + [(list& in ins) out]) + + _ + [(list) type])) + +(def: #export (flatten-apply type) + (-> Type [Type (List Type)]) + (case type + (#;AppT left' right) + (let [[left rights] (flatten-apply left')] + [left (List/append rights (list right))]) + + _ + [type (list)])) + +(do-template [<name> <tag>] + [(def: #export (<name> type) + (-> Type (List Type)) + (case type + (<tag> left right) + (list& left (<name> right)) + + _ + (list type)))] + + [flatten-sum #;SumT] + [flatten-prod #;ProdT] + ) + +(def: #export (apply-type type-fun param) + (-> Type Type (Maybe Type)) + (case type-fun + (^template [<tag>] + (<tag> env body) + (#;Some (beta-reduce (list& type-fun param env) body))) + ([#;UnivQ] [#;ExQ]) + + (#;AppT F A) + (do Monad<Maybe> + [type-fn* (apply-type F A)] + (apply-type type-fn* param)) + + (#;NamedT name type) + (apply-type type param) + + _ + #;None)) + +(def: #export (type-to-ast type) + (-> Type AST) + (case type + (#;HostT name params) + (` (#;HostT (~ (ast;text name)) + (list (~@ (List/map type-to-ast params))))) + + (^template [<tag>] + <tag> + (` <tag>)) + ([#;VoidT] [#;UnitT]) + + (^template [<tag>] + (<tag> idx) + (` (<tag> (~ (ast;nat idx))))) + ([#;VarT] [#;ExT] [#;BoundT]) + + (^template [<tag>] + (<tag> left right) + (` (<tag> (~ (type-to-ast left)) + (~ (type-to-ast right))))) + ([#;LambdaT] [#;AppT]) + + (^template [<tag> <macro> <flattener>] + (<tag> left right) + (` (<macro> (~@ (List/map type-to-ast (<flattener> type)))))) + ([#;SumT | flatten-sum] + [#;ProdT & flatten-prod]) + + (#;NamedT name sub-type) + (ast;symbol name) + + (^template [<tag>] + (<tag> env body) + (` (<tag> (list (~@ (List/map type-to-ast env))) + (~ (type-to-ast body))))) + ([#;UnivQ] [#;ExQ]) + )) + +(def: #export (type-to-text type) + (-> Type Text) + (case type + (#;HostT name params) + (case params + #;Nil + ($_ Text/append "(^ " name ")") + + _ + ($_ Text/append "(^ " name " " (|> params (List/map type-to-text) list;reverse (list;interpose " ") (List/fold Text/append "")) ")")) + + #;VoidT + "Void" + + #;UnitT + "Unit" + + (^template [<tag> <open> <close> <flatten>] + (<tag> _) + ($_ Text/append <open> + (|> (<flatten> type) + (List/map type-to-text) + list;reverse + (list;interpose " ") + (List/fold Text/append "")) + <close>)) + ([#;SumT "(| " ")" flatten-sum] + [#;ProdT "[" "]" flatten-prod]) + + (#;LambdaT input output) + (let [[ins out] (flatten-function type)] + ($_ Text/append "(-> " + (|> ins + (List/map type-to-text) + list;reverse + (list;interpose " ") + (List/fold Text/append "")) + " " (type-to-text out) ")")) + + (#;BoundT idx) + (Nat/encode idx) + + (#;VarT id) + ($_ Text/append "⌈v:" (Nat/encode id) "⌋") + + (#;ExT id) + ($_ Text/append "⟨e:" (Nat/encode id) "⟩") + + (#;AppT fun param) + (let [[type-fun type-args] (flatten-apply type)] + ($_ Text/append "(" (type-to-text type-fun) " " (|> type-args (List/map type-to-text) list;reverse (list;interpose " ") (List/fold Text/append "")) ")")) + + (#;UnivQ env body) + ($_ Text/append "(All " (type-to-text body) ")") + + (#;ExQ env body) + ($_ Text/append "(Ex " (type-to-text body) ")") + + (#;NamedT [module name] type) + ($_ Text/append module ";" name) + )) + +(def: #export (un-alias type) + (-> Type Type) + (case type + (#;NamedT _ (#;NamedT ident type')) + (un-alias (#;NamedT ident type')) + + _ + type)) + +(def: #export (un-name type) + (-> Type Type) + (case type + (#;NamedT ident type') + (un-name type') + + _ + type)) diff --git a/stdlib/source/lux/type/auto.lux b/stdlib/source/lux/type/auto.lux new file mode 100644 index 000000000..a1a795c80 --- /dev/null +++ b/stdlib/source/lux/type/auto.lux @@ -0,0 +1,211 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monad) + (data [text] + text/format + [number] + (struct [list "List/" Monad<List> Fold<List>] + [dict]) + [bool] + [product]) + [compiler #+ Monad<Lux>] + (macro [ast] + ["s" syntax #+ syntax: Syntax]) + [type] + (type ["tc" check #+ Check Monad<Check>]) + )) + +(def: (find-member-type idx sig-type) + (-> Nat Type (Check Type)) + (case sig-type + (#;NamedT _ sig-type') + (find-member-type idx sig-type') + + (#;AppT func arg) + (case (type;apply-type func arg) + #;None + (tc;fail (format "Can't apply type " (%type func) " to type " (%type arg))) + + (#;Some sig-type') + (find-member-type idx sig-type')) + + (#;ProdT left right) + (if (=+ +0 idx) + (:: Monad<Check> wrap left) + (find-member-type (dec+ idx) right)) + + _ + (if (=+ +0 idx) + (:: Monad<Check> wrap sig-type) + (tc;fail (format "Can't find member type " (%n idx) " for " (%type sig-type)))))) + +(def: (resolve-member member) + (-> Ident (Lux [Nat Type])) + (do Monad<Lux> + [member (compiler;normalize member) + [idx tag-list sig-type] (compiler;resolve-tag member)] + (wrap [idx sig-type]))) + +(def: (prepare-defs this-module-name defs) + (-> Text (List [Text Def]) (List [Ident Type])) + (|> defs + (list;filter (lambda [[name [def-type def-anns def-value]]] + (compiler;struct? def-anns))) + (List/map (lambda [[name [def-type def-anns def-value]]] + [[this-module-name name] def-type])))) + +(def: local-env + (Lux (List [Ident Type])) + (do Monad<Lux> + [local-batches compiler;locals + #let [total-locals (List/fold (lambda [[name type] table] + (dict;put~ name type table)) + (: (dict;Dict Text Type) + (dict;new text;Hash<Text>)) + (List/join local-batches))]] + (wrap (|> total-locals + dict;entries + (List/map (lambda [[name type]] [["" name] type])))))) + +(def: local-structs + (Lux (List [Ident Type])) + (do Monad<Lux> + [this-module-name compiler;current-module-name + defs (compiler;defs this-module-name)] + (wrap (prepare-defs this-module-name defs)))) + +(def: import-structs + (Lux (List [Ident Type])) + (do Monad<Lux> + [this-module-name compiler;current-module-name + imp-mods (compiler;imported-modules this-module-name) + export-batches (mapM @ compiler;exports imp-mods)] + (wrap (prepare-defs this-module-name (List/join export-batches))))) + +(def: (apply-function-type func arg) + (-> Type Type (Check Type)) + (case func + (#;NamedT _ func') + (apply-function-type func' arg) + + (#;UnivQ _) + (do Monad<Check> + [[id var] tc;create-var] + (apply-function-type (default (undefined) + (type;apply-type func var)) + arg)) + + (#;LambdaT input output) + (do Monad<Check> + [_ (tc;check input arg)] + (wrap output)) + + _ + (tc;fail (format "Invalid function type: " (%type func))))) + +(def: (check-apply member-type input-types output-type) + (-> Type (List Type) Type (Check [])) + (do Monad<Check> + [member-type' (foldM Monad<Check> + (lambda [input member] + (apply-function-type member input)) + member-type + input-types)] + (tc;check output-type member-type'))) + +(def: compiler-type-context + (Lux tc;Context) + (lambda [compiler] + (let [type-vars (get@ #;type-vars compiler) + context (|> tc;fresh-context + (set@ #tc;var-id (get@ #;counter type-vars)) + (set@ #tc;bindings (dict;from-list number;Hash<Nat> (get@ #;mappings type-vars))))] + (#;Right [compiler context])))) + +(def: (test-alternatives sig-type member-idx input-types output-type alts) + (-> Type Nat (List Type) Type (List [Ident Type]) (Lux (List Ident))) + (do Monad<Lux> + [context compiler-type-context] + (case (|> alts + (list;filter (lambda [[alt-name alt-type]] + (case (tc;run context + (do Monad<Check> + [_ (tc;check sig-type alt-type) + member-type (find-member-type member-idx alt-type)] + (check-apply member-type input-types output-type))) + (#;Left error) + false + + (#;Right _) + true))) + (List/map product;left)) + #;Nil + (compiler;fail "No alternatives.") + + found + (wrap found)))) + +(def: (find-alternatives sig-type member-idx input-types output-type) + (-> Type Nat (List Type) Type (Lux (List Ident))) + (let [test (test-alternatives sig-type member-idx input-types output-type)] + ($_ compiler;either + (do Monad<Lux> [alts local-env] (test alts)) + (do Monad<Lux> [alts local-structs] (test alts)) + (do Monad<Lux> [alts import-structs] (test alts))))) + +(def: (var? input) + (-> AST Bool) + (case input + [_ (#;SymbolS _)] + true + + _ + false)) + +(def: (join-pair [l r]) + (All [a] (-> [a a] (List a))) + (list l r)) + +(syntax: #export (::: {member s;symbol} + {args (s;alt (s;some s;symbol) + (s;some s;any))}) + (case args + (#;Left args) + (do @ + [[member-idx sig-type] (resolve-member member) + input-types (mapM @ compiler;find-type args) + output-type compiler;expected-type + chosen-ones (find-alternatives sig-type member-idx input-types output-type)] + (case chosen-ones + #;Nil + (compiler;fail (format "No structure option could be found for member " (%ident member))) + + (#;Cons chosen #;Nil) + (wrap (list (` (:: (~ (ast;symbol chosen)) + (~ (ast;symbol member)) + (~@ (List/map ast;symbol args)))))) + + _ + (compiler;fail (format "Too many available options: " + (|> chosen-ones + (List/map %ident) + (text;join-with ", ") + ))))) + + (#;Right args) + (do @ + [#let [args-to-bind (list;filter (bool;complement var?) args)] + labels (seqM @ (list;repeat (list;size args-to-bind) + (compiler;gensym ""))) + #let [retry (` (let [(~@ (|> (list;zip2 labels args-to-bind) (List/map join-pair) List/join))] + (;;::: (~ (ast;symbol member)) (~@ labels))))]] + (wrap (list retry))))) + +(comment + (::: map inc (list 0 1 2 3 4)) + ) diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux new file mode 100644 index 000000000..9eb72cbcb --- /dev/null +++ b/stdlib/source/lux/type/check.lux @@ -0,0 +1,518 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + applicative + monad) + (data [text "Text/" Monoid<Text> Eq<Text>] + text/format + [number] + maybe + (struct [list] + [dict]) + error) + [type "Type/" Eq<Type>] + )) + +(type: #export Id Nat) + +(type: #export Fixpoints (List [[Type Type] Bool])) + +(type: #export Context + {#var-id Id + #ex-id Id + #bindings (dict;Dict Id (Maybe Type)) + #fixpoints Fixpoints + }) + +(type: #export (Check a) + (-> Context (Error [Context a]))) + +(struct: #export _ (Functor Check) + (def: (map f fa) + (lambda [context] + (case (fa context) + (#;Left error) + (#;Left error) + + (#;Right [context' output]) + (#;Right [context' (f output)]) + )))) + +(struct: #export _ (Applicative Check) + (def: functor Functor<Check>) + + (def: (wrap x) + (lambda [context] + (#;Right [context x]))) + + (def: (apply ff fa) + (lambda [context] + (case (ff context) + (#;Right [context' f]) + (case (fa context') + (#;Right [context'' a]) + (#;Right [context'' (f a)]) + + (#;Left error) + (#;Left error)) + + (#;Left error) + (#;Left error) + ))) + ) + +(struct: #export _ (Monad Check) + (def: applicative Applicative<Check>) + + (def: (join ffa) + (lambda [context] + (case (ffa context) + (#;Right [context' fa]) + (case (fa context') + (#;Right [context'' a]) + (#;Right [context'' a]) + + (#;Left error) + (#;Left error)) + + (#;Left error) + (#;Left error) + ))) + ) + +(open Monad<Check> "Check/") + +## [[Logic]] +(def: #export (run context proc) + (All [a] (-> Context (Check a) (Error a))) + (case (proc context) + (#;Left error) + (#;Left error) + + (#;Right [context' output]) + (#;Right output))) + +(def: (apply-type! t-func t-arg) + (-> Type Type (Check Type)) + (lambda [context] + (case (type;apply-type t-func t-arg) + #;None + (#;Left (format "Invalid type application: " (type;type-to-text t-func) " on " (type;type-to-text t-arg))) + + (#;Some output) + (#;Right [context output])))) + +(def: #export existential + (Check [Id Type]) + (lambda [context] + (let [id (get@ #ex-id context)] + (#;Right [(update@ #ex-id inc+ context) + [id (#;ExT id)]])))) + +(def: (bound? id) + (-> Id (Check Bool)) + (lambda [context] + (case (|> context (get@ #bindings) (dict;get id)) + (#;Some (#;Some _)) + (#;Right [context true]) + + (#;Some #;None) + (#;Right [context false]) + + #;None + (#;Left (format "Unknown type-var: " (%n id)))))) + +(def: (deref id) + (-> Id (Check Type)) + (lambda [context] + (case (|> context (get@ #bindings) (dict;get id)) + (#;Some (#;Some type)) + (#;Right [context type]) + + (#;Some #;None) + (#;Left (format "Unbound type-var: " (%n id))) + + #;None + (#;Left (format "Unknown type-var: " (%n id)))))) + +(def: (set-var id type) + (-> Id Type (Check [])) + (lambda [context] + (case (|> context (get@ #bindings) (dict;get id)) + (#;Some (#;Some bound)) + (#;Left (format "Can't rebind type-var: " (%n id) " | Current type: " (type;type-to-text bound))) + + (#;Some #;None) + (#;Right [(update@ #bindings (dict;put id (#;Some type)) context) + []]) + + #;None + (#;Left (format "Unknown type-var: " (%n id)))))) + +(def: (reset-var id type) + (-> Id Type (Check [])) + (lambda [context] + (case (|> context (get@ #bindings) (dict;get id)) + (#;Some _) + (#;Right [(update@ #bindings (dict;put id (#;Some type)) context) + []]) + + #;None + (#;Left (format "Unknown type-var: " (%n id)))))) + +(def: (unset-var id) + (-> Id (Check [])) + (lambda [context] + (case (|> context (get@ #bindings) (dict;get id)) + (#;Some _) + (#;Right [(update@ #bindings (dict;put id #;None) context) + []]) + + #;None + (#;Left (format "Unknown type-var: " (%n id)))))) + +(def: (clean t-id type) + (-> Id Type (Check Type)) + (case type + (#;VarT id) + (if (=+ t-id id) + (do Monad<Check> + [? (bound? id)] + (if ? + (deref id) + (wrap type))) + (do Monad<Check> + [? (bound? id)] + (if ? + (do Monad<Check> + [=type (deref id) + ==type (clean t-id =type)] + (case ==type + (#;VarT =id) + (if (=+ t-id =id) + (do Monad<Check> + [_ (unset-var id)] + (wrap type)) + (do Monad<Check> + [_ (reset-var id ==type)] + (wrap type))) + + _ + (do Monad<Check> + [_ (reset-var id ==type)] + (wrap type)))) + (wrap type)))) + + (#;HostT name params) + (do Monad<Check> + [=params (mapM @ (clean t-id) params)] + (wrap (#;HostT name =params))) + + (^template [<tag>] + (<tag> left right) + (do Monad<Check> + [=left (clean t-id left) + =right (clean t-id right)] + (wrap (<tag> =left =right)))) + ([#;LambdaT] + [#;AppT] + [#;ProdT] + [#;SumT]) + + (^template [<tag>] + (<tag> env body) + (do Monad<Check> + [=env (mapM @ (clean t-id) env) + =body (clean t-id body)] ## TODO: DON'T CLEAN THE BODY + (wrap (<tag> =env =body)))) + ([#;UnivQ] + [#;ExQ]) + + _ + (:: Monad<Check> wrap type) + )) + +(def: #export create-var + (Check [Id Type]) + (lambda [context] + (let [id (get@ #var-id context)] + (#;Right [(|> context + (update@ #var-id inc+) + (update@ #bindings (dict;put id #;None))) + [id (#;VarT id)]])))) + +(do-template [<get> <set> <tag> <type>] + [(def: <get> + (Check <type>) + (lambda [context] + (#;Right [context + (get@ <tag> context)]))) + + (def: (<set> value) + (-> <type> (Check [])) + (lambda [context] + (#;Right [(set@ <tag> value context) + []])))] + + [get-bindings set-bindings #bindings (dict;Dict Id (Maybe Type))] + [get-fixpoints set-fixpoints #fixpoints Fixpoints] + ) + +(def: #export (delete-var id) + (-> Id (Check [])) + (do Monad<Check> + [? (bound? id) + _ (if ? + (wrap []) + (do Monad<Check> + [[ex-id ex] existential] + (set-var id ex))) + bindings get-bindings + bindings' (mapM @ + (lambda [(^@ binding [b-id b-type])] + (if (=+ id b-id) + (wrap binding) + (case b-type + #;None + (wrap binding) + + (#;Some b-type') + (case b-type' + (#;VarT t-id) + (if (=+ id t-id) + (wrap [b-id #;None]) + (wrap binding)) + + _ + (do Monad<Check> + [b-type'' (clean id b-type')] + (wrap [b-id (#;Some b-type'')]))) + ))) + (dict;entries bindings))] + (set-bindings (|> bindings' (dict;from-list number;Hash<Nat>) (dict;remove id))))) + +(def: #export (with-var k) + (All [a] (-> (-> [Id Type] (Check a)) (Check a))) + (do Monad<Check> + [[id var] create-var + output (k [id var]) + _ (delete-var id)] + (wrap output))) + +(def: #export fresh-context + Context + {#var-id +0 + #ex-id +0 + #bindings (dict;new number;Hash<Nat>) + #fixpoints (list) + }) + +(def: (attempt op) + (All [a] (-> (Check a) (Check (Maybe a)))) + (lambda [context] + (case (op context) + (#;Right [context' output]) + (#;Right [context' (#;Some output)]) + + (#;Left _) + (#;Right [context #;None])))) + +(def: #export (fail message) + (All [a] (-> Text (Check a))) + (lambda [context] + (#;Left message))) + +(def: (fail-check expected actual) + (-> Type Type (Check [])) + (fail (format "Expected: " (type;type-to-text expected) "\n\n" + "Actual: " (type;type-to-text actual)))) + +(def: success (Check []) (Check/wrap [])) + +(def: (|| left right) + (All [a] (-> (Check a) (Check a) (Check a))) + (lambda [context] + (case (left context) + (#;Right [context' output]) + (#;Right [context' output]) + + (#;Left _) + (right context)))) + +(def: (fp-get [e a] fixpoints) + (-> [Type Type] Fixpoints (Maybe Bool)) + (list;find (lambda [[[fe fa] status]] + (if (and (Type/= e fe) + (Type/= a fa)) + (#;Some status) + #;None)) + fixpoints)) + +(def: (fp-put ea status fixpoints) + (-> [Type Type] Bool Fixpoints Fixpoints) + (#;Cons [ea status] fixpoints)) + +(def: #export (check expected actual) + (-> Type Type (Check [])) + (if (== expected actual) + success + (case [expected actual] + [(#;VarT e-id) (#;VarT a-id)] + (if (=+ e-id a-id) + success + (do Monad<Check> + [ebound (attempt (deref e-id)) + abound (attempt (deref a-id))] + (case [ebound abound] + [#;None #;None] + (set-var e-id actual) + + [(#;Some etype) #;None] + (check etype actual) + + [#;None (#;Some atype)] + (check expected atype) + + [(#;Some etype) (#;Some atype)] + (check etype atype)))) + + [(#;VarT id) _] + (|| (set-var id actual) + (do Monad<Check> + [bound (deref id)] + (check bound actual))) + + [_ (#;VarT id)] + (|| (set-var id expected) + (do Monad<Check> + [bound (deref id)] + (check expected bound))) + + [(#;AppT (#;ExT eid) eA) (#;AppT (#;ExT aid) aA)] + (if (=+ eid aid) + (check eA aA) + (fail-check expected actual)) + + [(#;AppT (#;VarT id) A1) (#;AppT F2 A2)] + (|| (do Monad<Check> + [F1 (deref id)] + (check (#;AppT F1 A1) actual)) + (do Monad<Check> + [_ (check (#;VarT id) F2) + e' (apply-type! F2 A1) + a' (apply-type! F2 A2)] + (check e' a'))) + + [(#;AppT F1 A1) (#;AppT (#;VarT id) A2)] + (|| (do Monad<Check> + [F2 (deref id)] + (check expected (#;AppT F2 A2))) + (do Monad<Check> + [_ (check F1 (#;VarT id)) + e' (apply-type! F1 A1) + a' (apply-type! F1 A2)] + (check e' a'))) + + [(#;AppT F A) _] + (do Monad<Check> + [#let [fp-pair [expected actual]] + fixpoints get-fixpoints] + (case (fp-get fp-pair fixpoints) + (#;Some ?) + (if ? + success + (fail-check expected actual)) + + #;None + (do Monad<Check> + [expected' (apply-type! F A) + _ (set-fixpoints (fp-put fp-pair true fixpoints))] + (check expected' actual)))) + + [_ (#;AppT F A)] + (do Monad<Check> + [actual' (apply-type! F A)] + (check expected actual')) + + [(#;UnivQ _) _] + (do Monad<Check> + [[ex-id ex] existential + expected' (apply-type! expected ex)] + (check expected' actual)) + + [_ (#;UnivQ _)] + (with-var + (lambda [[var-id var]] + (do Monad<Check> + [actual' (apply-type! actual var) + =output (check expected actual') + _ (clean var-id expected)] + success))) + + [(#;ExQ e!env e!def) _] + (with-var + (lambda [[var-id var]] + (do Monad<Check> + [expected' (apply-type! expected var) + =output (check expected' actual) + _ (clean var-id actual)] + success))) + + [_ (#;ExQ a!env a!def)] + (do Monad<Check> + [[ex-id ex] existential + actual' (apply-type! actual ex)] + (check expected actual')) + + [(#;HostT e-name e-params) (#;HostT a-name a-params)] + (if (Text/= e-name a-name) + (do Monad<Check> + [_ (mapM Monad<Check> + (lambda [[e a]] (check e a)) + (list;zip2 e-params a-params))] + success) + (fail-check expected actual)) + + (^template [<unit> <append>] + [<unit> <unit>] + success + + [(<append> eL eR) (<append> aL aR)] + (do Monad<Check> + [_ (check eL aL)] + (check eR aR))) + ([#;VoidT #;SumT] + [#;UnitT #;ProdT]) + + [(#;LambdaT eI eO) (#;LambdaT aI aO)] + (do Monad<Check> + [_ (check aI eI)] + (check eO aO)) + + [(#;ExT e!id) (#;ExT a!id)] + (if (=+ e!id a!id) + success + (fail-check expected actual)) + + [(#;NamedT _ ?etype) _] + (check ?etype actual) + + [_ (#;NamedT _ ?atype)] + (check expected ?atype) + + _ + (fail-check expected actual)))) + +(def: #export (checks? expected actual) + (-> Type Type Bool) + (case (run fresh-context (check expected actual)) + (#;Left error) + false + + (#;Right _) + true)) diff --git a/stdlib/test/test/lux.lux b/stdlib/test/test/lux.lux new file mode 100644 index 000000000..947ec5b6f --- /dev/null +++ b/stdlib/test/test/lux.lux @@ -0,0 +1,164 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + lux/test + (lux (control monad) + (codata [io]) + [math] + (math ["R" random]) + (data text/format) + [compiler] + (macro ["s" syntax #+ syntax:]))) + +(test: "Every value is identical to itself, and the 'id' function doesn't change values in any way." + [value R;int] + (assert "" (and (== value value) + (== value (id value))))) + +(test: "Values created separately can't be identical." + [x R;int + y R;int] + (match false (== x y))) + +(do-template [category rand-gen inc dec even? odd? = < >] + [(test: (format "[" category "] " "Moving up-down or down-up should result in same value.") + [value rand-gen] + (assert "" (and (|> value inc dec (= value)) + (|> value dec inc (= value))))) + + (test: (format "[" category "] " "(x+1) > x && (x-1) < x") + [value rand-gen] + (assert "" (and (|> value inc (> value)) + (|> value dec (< value))))) + + (test: (format "[" category "] " "Every odd/even number is surrounded by two of the other kind.") + [value rand-gen] + (assert "" + (if (even? value) + (and (|> value inc odd?) + (|> value dec odd?)) + (and (|> value inc even?) + (|> value dec even?)))))] + + ["Nat" R;nat inc+ dec+ even?+ odd?+ =+ <+ >+] + ["Int" R;int inc dec even? odd? = < >] + ) + +(do-template [category rand-gen = < > <= >= min max] + [(test: (format "[" category "] " "The symmetry of numerical comparisons.") + [x rand-gen + y rand-gen] + (assert "" + (or (= x y) + (if (< y x) + (> x y) + (< x y))))) + + (test: (format "[" category "] " "Minimums and maximums.") + [x rand-gen + y rand-gen] + (assert "" + (and (and (<= x (min x y)) + (<= y (min x y))) + (and (>= x (max x y)) + (>= y (max x y))) + )))] + + ["Int" R;int = < > <= >= min max] + ["Nat" R;nat =+ <+ >+ <=+ >=+ min+ max+] + ["Real" R;real =. <. >. <=. >=. min. max.] + ["Frac" R;frac =.. <.. >.. <=.. >=.. min.. max..] + ) + +(do-template [category rand-gen = + - * / <%> > <0> <1> <10> %x <cap> <prep>] + [(test: (format "[" category "] " "Additive identity") + [x rand-gen] + (assert "" + (and (|> x (+ <0>) (= x)) + (|> x (- <0>) (= x))))) + + (test: (format "[" category "] " "Addition & Substraction") + [x (:: @ map <prep> rand-gen) + y (:: @ map <prep> rand-gen) + #let [x (* <10> x) + y (* <10> y) + cond (and (|> x (- y) (+ y) (= x)) + (|> x (+ y) (- y) (= x))) + _ (if cond + [] + (exec + (log! "+- SAMPLE") + (log! (format (%x x) " -+ " (%x y) " = " (%x (|> x (- y) (+ y))))) + (log! (format (%x x) " +- " (%x y) " = " (%x (|> x (+ y) (- y))))))) + ]] + (assert "" + (and (|> x (- y) (+ y) (= x)) + (|> x (+ y) (- y) (= x))))) + + (test: (format "[" category "] " "Multiplicative identity") + [x rand-gen] + (assert "" + (and (|> x (* <1>) (= x)) + (|> x (/ <1>) (= x))))) + + (test: (format "[" category "] " "Multiplication & Division") + [x (:: @ map <cap> rand-gen) + y (|> rand-gen + (:: @ map <cap>) + (R;filter (|>. (= <0>) not))) + #let [r (<%> y x) + x' (- r x)]] + (assert "" + (or (> x' y) + (|> x' (/ y) (* y) (= x'))) + ))] + + ["Nat" R;nat =+ ++ -+ *+ /+ ;%+ >+ +0 +1 +1000000 %n (;%+ +1000) id] + ["Int" R;int = + - * / ;% > 0 1 1000000 %i (;% 1000) id] + ["Real" R;real =. +. -. *. /. ;%. >. 0.0 1.0 1000000.0 %r id math;floor] + ) + +(do-template [category rand-gen -> <- = <cap> %a %z] + [(test: (format "[" category "] " "Numeric conversions") + [value rand-gen + #let [value (<cap> value)]] + (assert "" + (|> value -> <- (= value))))] + + ["Int->Nat" R;int int-to-nat nat-to-int = (;% 1000000) %i %n] + ["Nat->Int" R;nat nat-to-int int-to-nat =+ (;%+ +1000000) %n %i] + ["Int->Real" R;int int-to-real real-to-int = (;% 1000000) %i %r] + ["Real->Int" R;real real-to-int int-to-real =. math;floor %r %i] + ## [R;real real-to-frac frac-to-real =. (;%. 1.0) %r %f] + ) + +(test: "Simple macros and constructs" + (all (match ["lux" "yolo"] (ident-for ;yolo)) + (match ["test/lux" "yolo"] (ident-for ;;yolo)) + (match ["" "yolo"] (ident-for yolo)) + (match ["lux/test" "yolo"] (ident-for lux/test;yolo)) + (match ["lux" "yolo"] (ident-for #;yolo)) + (match ["test/lux" "yolo"] (ident-for #;;yolo)) + (match ["" "yolo"] (ident-for #yolo)) + (match ["lux/test" "yolo"] (ident-for #lux/test;yolo)) + + (match 1000 (loop [counter 0 + value 1] + (if (< 3 counter) + (recur (inc counter) (* 10 value)) + value))) + + (match (^ (list 1 2 3)) + (list 1 2 3)) + (match (^ (list 1 2 3 4 5 6)) + (list& 1 2 3 (list 4 5 6))) + + (match "yolo" (default "yolo" + #;None)) + (match "lol" (default "yolo" + (#;Some "lol"))) + )) diff --git a/stdlib/test/test/lux/cli.lux b/stdlib/test/test/lux/cli.lux new file mode 100644 index 000000000..c95ec9e9c --- /dev/null +++ b/stdlib/test/test/lux/cli.lux @@ -0,0 +1,84 @@ +(;module: + [lux #- not] + (lux (codata [io]) + (control monad) + (data text/format + [number] + [product] + [sum]) + (codata function) + [cli #- run]) + [lux/test #- assert]) + +(test: "lux/cli exports" + (test-all (match (#;Right "foo") + (cli;run any (list "foo" "bar" "baz"))) + (match (#;Left _) + (cli;run any (list))) + (match (#;Right 123) + (cli;run (parse (:: number;Codec<Text,Int> decode) any) (list "123"))) + (match (#;Left _) + (cli;run (option (list "-p" "--port")) (list))) + (match (#;Left _) + (cli;run (option (list "-p" "--port")) (list "yolo"))) + (match (#;Right "123") + (cli;run (option (list "-p" "--port")) (list "-p" "123"))) + (match (#;Right "123") + (cli;run (option (list "-p" "--port")) (list "--port" "123"))) + (match (#;Right false) + (cli;run (flag (list "-h" "--help")) (list))) + (match (#;Right false) + (cli;run (flag (list "-h" "--help")) (list "yolo"))) + (match (#;Right true) + (cli;run (flag (list "-h" "--help")) (list "-h"))) + (match (#;Right true) + (cli;run (flag (list "-h" "--help")) (list "--help"))) + (match (#;Right []) + (cli;run end (list))) + (match (#;Left _) + (cli;run end (list "yolo"))) + (match (#;Left "YOLO") + (cli;run (assert false "YOLO") (list "yolo"))) + (match (#;Right []) + (cli;run (assert true "YOLO") (list "yolo"))) + (match (#;Right #;None) + (cli;run (opt any) (list))) + (match (#;Right (#;Some "yolo")) + (cli;run (opt any) (list "yolo"))) + (match (#;Right ["foo" "bar"]) + (cli;run (seq any any) (list "foo" "bar" "baz"))) + (match (#;Right ["foo" "bar"]) + (cli;run (seq any any) (list "foo" "bar"))) + (match (#;Left _) + (cli;run (seq any any) (list "foo"))) + ## (match (#;Right (#;Left 123)) + ## (cli;run (alt (parse (:: number;Codec<Text,Int> decode) any) + ## any) + ## (list "123" "foo"))) + ## (match (#;Right (#;Right "foo")) + ## (cli;run (alt (parse (:: number;Codec<Text,Int> decode) any) + ## any) + ## (list "foo"))) + (match (#;Left _) + (cli;run (alt (parse (:: number;Codec<Text,Int> decode) any) + (parse (:: number;Codec<Text,Real> decode) any)) + (list "foo"))) + (match (#;Left _) + (cli;run (not (parse (:: number;Codec<Text,Int> decode) any)) + (list "123"))) + (match (#;Right []) + (cli;run (not (parse (:: number;Codec<Text,Int> decode) any)) + (list "yolo"))) + (match (^ (#;Right (list "foo" "bar" "baz"))) + (cli;run (some any) (list "foo" "bar" "baz"))) + (match (^ (#;Right (list))) + (cli;run (some any) (list))) + (match (^ (#;Right (list "foo" "bar" "baz"))) + (cli;run (many any) (list "foo" "bar" "baz"))) + (match (#;Left _) + (cli;run (many any) (list))) + (match (#;Right "yolo") + (cli;run (either (parse sum;right any) + any) + (list "yolo"))) + )) diff --git a/stdlib/test/test/lux/codata/env.lux b/stdlib/test/test/lux/codata/env.lux new file mode 100644 index 000000000..7a374cd4d --- /dev/null +++ b/stdlib/test/test/lux/codata/env.lux @@ -0,0 +1,23 @@ +(;module: + lux + (lux (codata [io]) + (control monad) + (data [text "Text/" Monoid<Text>] + text/format + [number]) + (codata function + env)) + lux/test) + +(test: "lux/codata/env exports" + (test-all (match 123 (run 123 ask)) + (match 246 (run 123 (local (* 2) ask))) + (match 134 (run 123 (:: Functor<Env> map inc (+ 10)))) + (match 10 (run 123 (:: Applicative<Env> wrap 10))) + (match 30 (run 123 (let [(^open) Applicative<Env>] + (apply (wrap (+ 10)) (wrap 20))))) + (match 30 (run 123 (do Monad<Env> + [f (wrap +) + x (wrap 10) + y (wrap 20)] + (wrap (f x y))))))) diff --git a/stdlib/test/test/lux/codata/io.lux b/stdlib/test/test/lux/codata/io.lux new file mode 100644 index 000000000..5d521faff --- /dev/null +++ b/stdlib/test/test/lux/codata/io.lux @@ -0,0 +1,21 @@ +(;module: + lux + (lux (control monad) + (data [text "Text/" Monoid<Text>] + text/format + [number]) + (codata function + io)) + lux/test) + +(test: "lux/codata/io exports" + (test-all (match "YOLO" (run (io "YOLO"))) + (match 11 (run (:: Functor<IO> map inc (io 10)))) + (match 10 (run (:: Applicative<IO> wrap 10))) + (match 30 (run (let [(^open) Applicative<IO>] + (apply (wrap (+ 10)) (wrap 20))))) + (match 30 (run (do Monad<IO> + [f (wrap +) + x (wrap 10) + y (wrap 20)] + (wrap (f x y))))))) diff --git a/stdlib/test/test/lux/codata/state.lux b/stdlib/test/test/lux/codata/state.lux new file mode 100644 index 000000000..054b59d45 --- /dev/null +++ b/stdlib/test/test/lux/codata/state.lux @@ -0,0 +1,34 @@ +(;module: + lux + (lux (codata [io]) + (control monad) + (data [text "Text/" Monoid<Text>] + text/format + [number] + [product]) + (codata function + state)) + lux/test) + +(test: "lux/codata/state exports" + (test-all (match 123 (product;right (run 123 get))) + (match 321 (product;right (run 123 (do Monad<State> + [_ (put 321)] + get)))) + (match 369 (product;right (run 123 (do Monad<State> + [_ (update (* 3))] + get)))) + (match 124 (product;right (run 123 (use inc)))) + (match 246 (product;right (run 123 (local (* 2) get)))) + (match 124 (product;right (run 123 (:: Functor<State> map inc get)))) + (match 10 (product;right (run 123 (:: Applicative<State> wrap 10)))) + (match 30 (product;right (run 123 (let [(^open) Applicative<State>] + (apply (wrap (+ 10)) (wrap 20)))))) + (match 30 (product;right (run 123 (: (State Int Int) + (do Monad<State> + [f (wrap +) + x (wrap 10) + y (wrap 20)] + + (wrap (f x y))))))) + )) diff --git a/stdlib/test/test/lux/codata/struct/stream.lux b/stdlib/test/test/lux/codata/struct/stream.lux new file mode 100644 index 000000000..28292a405 --- /dev/null +++ b/stdlib/test/test/lux/codata/struct/stream.lux @@ -0,0 +1,68 @@ +(;module: + lux + (lux (codata [io]) + (control monad + comonad) + (data [text "Text/" Monoid<Text>] + text/format + [number "Int/" Codec<Text,Int>]) + (codata function + [cont] + (struct stream))) + lux/test) + +(test: "lux/codata/stream exports" + (let% [<take+drop+split> (do-template [<take> <drop> <split> <arg>] + [(match (^ (list 0 1 2)) + (<take> <arg> (iterate inc 0))) + (match (^=> (^stream& w x y z ...) + {[w x y z] [3 4 5 6]}) + (<drop> <arg> (iterate inc 0))) + (match (^=> (^ [(list 0 1 2) _stream_]) + {_stream_ (^stream& w x y z ...)} + {[w x y z] [3 4 5 6]}) + (<split> <arg> (iterate inc 0)))] + + [take drop split +3] + [take-while drop-while split-with (< 3)]) + ] + (test-all (match (^=> (^stream& w x y z ...) + {[w x y z] [0 1 2 3]}) + (iterate inc 0)) + (match (^=> (^stream& w x y z ...) + {[w x y z] [0 0 0 0]}) + (repeat 0)) + (match (^=> (#;Some the-stream) + {the-stream (^stream& w x y z ...)} + {[w x y z] [0 1 0 1]}) + (cycle (list 0 1))) + (match 0 (head (iterate inc 0))) + (match (^=> (^stream& w x y z ...) + {[w x y z] [1 2 3 4]}) + (tail (iterate inc 0))) + (match 9 (at +9 (iterate inc 0))) + (match 0 (at +0 (iterate inc 0))) + <take+drop+split> + (match (^=> (^stream& w x y z ...) + {[w x y z] ["0" "1" "2" "3"]}) + (unfold (lambda [n] [(inc n) (Int/encode n)]) + 0)) + (match (^=> (^stream& w x y z ...) + {[w x y z] [0 2 4 6]}) + (filter even? (iterate inc 0))) + (match (^=> [e_stream o_stream] + {e_stream (^stream& w x y z ...)} + {o_stream (^stream& a b c d ...)} + {[w x y z a b c d] [0 2 4 6 1 3 5 7]}) + (partition even? (iterate inc 0))) + (match (^=> (^stream& w x y z ...) + {[w x y z] [0 1 4 9]}) + (let [square (lambda [n] (* n n))] + (:: Functor<Stream> map square (iterate inc 0)))) + (match (^=> (^stream& w x y z ...) + {[w x y z] [4 9 16 25]}) + (let [square (lambda [n] (* n n))] + (be CoMonad<Stream> + [inputs (iterate inc 2)] + (square (head inputs))))) + ))) diff --git a/stdlib/test/test/lux/concurrency/actor.lux b/stdlib/test/test/lux/concurrency/actor.lux new file mode 100644 index 000000000..e9a19e8ea --- /dev/null +++ b/stdlib/test/test/lux/concurrency/actor.lux @@ -0,0 +1,70 @@ +(;module: + lux + (lux (control monad) + (data [number] + text/format + error) + (concurrency [promise #+ Promise Monad<Promise> "Promise/" Monad<Promise>] + actor) + (codata function + [io #- run])) + lux/test) + +(actor: Adder + Int + + (method: (add! {offset Int}) + [Int Int] + (let [*state*' (+ offset *state*)] + (wrap (#;Right [*state*' [*state* *state*']])))) + + (stop: + (exec (log! (format "Cause of death: " (default "???" *cause*))) + (log! (format "Current state: " (%i *state*))) + (wrap [])))) + +(test: "lux/concurrency/actor exports" + (let [counter-proc (: (Proc Int (Promise Int)) + [(lambda [self output state] + (let [state' (inc state)] + (exec (io;run (promise;resolve state' output)) + (Promise/wrap (#;Right state'))))) + (lambda [?error state] (Promise/wrap []))])] + (test-all (match true + (let [counter (: (Actor Int (Promise Int)) + (io;run (spawn 0 counter-proc)))] + (alive? counter))) + (match [true false] + (let [counter (: (Actor Int (Promise Int)) + (io;run (spawn 0 counter-proc)))] + [(io;run (poison counter)) + (alive? counter)])) + (match [true false] + (let [counter (: (Actor Int (Promise Int)) + (io;run (spawn 0 counter-proc)))] + [(io;run (poison counter)) + (io;run (poison counter))])) + (match+ [1 2 3] + (do Monad<Promise> + [#let [counter (: (Actor Int (Promise Int)) + (io;run (spawn 0 counter-proc))) + output-1 (: (Promise Int) (promise;promise)) + output-2 (: (Promise Int) (promise;promise)) + output-3 (: (Promise Int) (promise;promise))] + ?1 (send output-1 counter) + ?2 (send output-2 counter) + ?3 (send output-3 counter)] + (if (and ?1 ?2 ?3) + (from-promise ($_ promise;seq output-1 output-2 output-3)) + (wrap (#;Left "Uh, oh..."))))) + (match+ [[0 1] [1 3] [3 6]] + (do Monad<Promise> + [#let [adder (: Adder + (io;run (spawn 0 Adder//new)))] + t1 (add! 1 adder) + t2 (add! 2 adder) + t3 (add! 3 adder) + #let [? (io;run (poison adder))]] + (wrap (#;Right [t1 t2 t3])) + )) + ))) diff --git a/stdlib/test/test/lux/concurrency/frp.lux b/stdlib/test/test/lux/concurrency/frp.lux new file mode 100644 index 000000000..62ca0b57d --- /dev/null +++ b/stdlib/test/test/lux/concurrency/frp.lux @@ -0,0 +1,54 @@ +(;module: + lux + (lux (control monad) + (data [number] + text/format + error) + (concurrency [promise #+ Promise Monad<Promise> "Promise/" Monad<Promise>] + frp) + (codata function + io)) + lux/test) + +(def: (List->Chan values) + (-> (List Int) (Chan Int)) + (let [_chan (: (Chan Int) (chan))] + (run (do Monad<IO> + [_ (mapM Monad<IO> + (lambda [value] + (write value _chan)) + values) + _ (close _chan)] + (wrap _chan))))) + +(test: "lux/concurrency/frp exports" + (test-all (match+ (^ (list 0 1 2 3 4 5)) + (from-promise (consume (List->Chan (list 0 1 2 3 4 5))))) + (match+ (^ (list 0 1 2 3 4 5)) + (from-promise (consume (let [input (List->Chan (list 0 1 2 3 4 5)) + output (: (Chan Int) (chan))] + (exec (pipe input output) + output))))) + (match+ (^ (list 0 2 4)) + (from-promise (consume (filter even? (List->Chan (list 0 1 2 3 4 5)))))) + (match+ (^ (list 0 1 2 3 4 5 0 -1 -2 -3 -4 -5)) + (from-promise (consume (merge (list (List->Chan (list 0 1 2 3 4 5)) + (List->Chan (list 0 -1 -2 -3 -4 -5))))))) + (match+ 15 (from-promise (fold (lambda [base input] (Promise/wrap (+ input base))) 0 (List->Chan (list 0 1 2 3 4 5))))) + (match+ (^ (list 0 1 2 3 4 5)) + (from-promise (consume (no-dups number;Eq<Int> (List->Chan (list 0 0 0 1 2 2 3 3 3 3 4 4 4 5 5)))))) + (match+ (^ (list 12345)) + (from-promise (consume (as-chan (:: promise;Monad<Promise> wrap 12345))))) + (match+ (^ (list 1 2 3 4 5 6)) + (from-promise (consume (:: Functor<Chan> map inc (List->Chan (list 0 1 2 3 4 5)))))) + (match+ (^ (list 12345)) + (from-promise (consume (:: Applicative<Chan> wrap 12345)))) + (match+ (^ (list 12346)) + (from-promise (consume (let [(^open) Applicative<Chan>] + (apply (wrap inc) (wrap 12345)))))) + (match+ (^ (list 12346)) + (from-promise (consume (do Monad<Chan> + [f (wrap inc) + a (wrap 12345)] + (wrap (f a)))))) + )) diff --git a/stdlib/test/test/lux/concurrency/promise.lux b/stdlib/test/test/lux/concurrency/promise.lux new file mode 100644 index 000000000..77e5a0aed --- /dev/null +++ b/stdlib/test/test/lux/concurrency/promise.lux @@ -0,0 +1,31 @@ +(;module: + lux + (lux (control monad) + (data [number] + text/format + error) + (concurrency promise) + (codata function + [io #*])) + lux/test) + +(test: "lux/concurrency/promise exports" + (test-all (match+ true (from-promise (future (io true)))) + (match+ [] (from-promise (wait +500))) + (match+ [true false] (from-promise (seq (future (io true)) + (future (io false))))) + (match+ (#;Left true) (from-promise (alt (delay +100 true) + (delay +200 false)))) + (match+ (#;Right false) (from-promise (alt (delay +200 true) + (delay +100 false)))) + (match+ true (from-promise (either (delay +100 true) + (delay +200 false)))) + (match+ false (from-promise (either (delay +200 true) + (delay +100 false)))) + (match (#;Some true) (poll (:: Monad<Promise> wrap true))) + (match #;None (poll (delay +200 true))) + (match false (io;run (resolve false (:: Monad<Promise> wrap true)))) + (match true (io;run (resolve true (: (Promise Bool) (promise))))) + (match+ #;None (from-promise (time-out +100 (delay +200 true)))) + (match+ (#;Some true) (from-promise (time-out +200 (delay +100 true)))) + )) diff --git a/stdlib/test/test/lux/concurrency/stm.lux b/stdlib/test/test/lux/concurrency/stm.lux new file mode 100644 index 000000000..e29a5294b --- /dev/null +++ b/stdlib/test/test/lux/concurrency/stm.lux @@ -0,0 +1,57 @@ +(;module: + lux + (lux (codata [io]) + (control monad) + (data [number] + (struct [list "" Functor<List>]) + text/format) + (concurrency stm + [promise]) + (codata function)) + lux/test) + +(def: vars Int 5) +(def: processes/vars Int 5) +(def: iterations/processes Int 100) + +(test: "lux/concurrency/stm exports" + (let [_var (var 0) + changes (io;run (follow "test" _var)) + tests (: (List (Test Int)) + (map (lambda [_] + (let [_concurrency-var (var 0)] + (from-promise (do promise;Monad<Promise> + [_ (seqM @ + (map (lambda [_] + (mapM @ (lambda [_] (commit (update inc _concurrency-var))) + (list;range 1 iterations/processes))) + (list;range 1 processes/vars)))] + (commit (read _concurrency-var)))))) + (list;range 1 vars)))] + (test-all (match+ 0 (commit (do Monad<STM> + [value (read _var)] + (wrap (#;Right value))))) + (match+ 5 (commit (do Monad<STM> + [_ (write 5 _var) + value (read _var)] + (wrap (#;Right value))))) + (match+ 5 (commit (do Monad<STM> + [value (read _var)] + (wrap (#;Right value))))) + (match+ 15 (commit (do Monad<STM> + [_ (update (* 3) _var) + value (read _var)] + (wrap (#;Right value))))) + (match+ 15 (commit (do Monad<STM> + [value (read _var)] + (wrap (#;Right value))))) + (match+ [5 15] (do promise;Monad<Promise> + [?c1+changes' changes + #let [[c1 changes'] (default [-1 changes] ?c1+changes')] + ?c2+changes' changes' + #let [[c2 changes'] (default [-1 changes] ?c2+changes')]] + (wrap (#;Right [c1 c2])))) + ## Temporarily commented-out due to type-checking bug in + ## compiler... + ## (match+ _ (seqM Monad<Test> tests)) + ))) diff --git a/stdlib/test/test/lux/data/bit.lux b/stdlib/test/test/lux/data/bit.lux new file mode 100644 index 000000000..e20027818 --- /dev/null +++ b/stdlib/test/test/lux/data/bit.lux @@ -0,0 +1,65 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control [monad]) + (codata [io]) + (data ["&" bit] + number) + (math ["R" random])) + lux/test) + +(def: width Nat +64) + +(test: "Bitwise operations." + [pattern R;nat + idx (:: @ map (%+ width) R;nat)] + (all (assert "" (and (<+ (&;count (&;set idx pattern)) + (&;count (&;clear idx pattern))) + (<=+ (&;count pattern) + (&;count (&;clear idx pattern))) + (>=+ (&;count pattern) + (&;count (&;set idx pattern))) + + (or (and (&;set? idx pattern) + (not (&;set? idx (&;clear idx pattern)))) + (and (not (&;set? idx pattern)) + (&;set? idx (&;set idx pattern)))) + + (or (and (&;set? idx pattern) + (not (&;set? idx (&;flip idx pattern)))) + (and (not (&;set? idx pattern)) + (&;set? idx (&;flip idx pattern)))) + + (=+ width + (++ (&;count pattern) + (&;count (&;~ pattern)))) + + (=+ +0 + (&;& pattern + (&;~ pattern))) + (=+ (&;~ +0) + (&;| pattern + (&;~ pattern))) + (=+ (&;~ +0) + (&;^ pattern + (&;~ pattern))) + (=+ +0 + (&;^ pattern + pattern)) + + (|> pattern (&;rotate-left idx) (&;rotate-right idx) (=+ pattern)) + (|> pattern (&;rotate-right idx) (&;rotate-left idx) (=+ pattern)) + (|> pattern (&;rotate-left idx) (&;rotate-left (-+ idx width)) (=+ pattern)) + (|> pattern (&;rotate-right idx) (&;rotate-right (-+ idx width)) (=+ pattern)) + )) + + (assert "Shift right respect the sign of ints." + (let [value (nat-to-int pattern)] + (if (< 0 value) + (< 0 (&;>> idx value)) + (>= 0 (&;>> idx value))))) + )) diff --git a/stdlib/test/test/lux/data/bool.lux b/stdlib/test/test/lux/data/bool.lux new file mode 100644 index 000000000..218846e2e --- /dev/null +++ b/stdlib/test/test/lux/data/bool.lux @@ -0,0 +1,38 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control [monad]) + (codata [io]) + (data bool) + (math ["R" random])) + lux/test) + +(test: "Boolean operations." + [value R;bool] + (assert "" (and (not (and value (not value))) + (or value (not value)) + + (not (:: Or@Monoid<Bool> unit)) + (:: Or@Monoid<Bool> append value (not value)) + (:: And@Monoid<Bool> unit) + (not (:: And@Monoid<Bool> append value (not value))) + + (:: Eq<Bool> = value (not (not value))) + (not (:: Eq<Bool> = value (not value))) + + (not (:: Eq<Bool> = value ((complement id) value))) + (:: Eq<Bool> = value ((complement not) value)) + + (case (|> value + (:: Codec<Text,Bool> encode) + (:: Codec<Text,Bool> decode)) + (#;Right dec-value) + (:: Eq<Bool> = value dec-value) + + (#;Left _) + false) + ))) diff --git a/stdlib/test/test/lux/data/char.lux b/stdlib/test/test/lux/data/char.lux new file mode 100644 index 000000000..ab2e84d59 --- /dev/null +++ b/stdlib/test/test/lux/data/char.lux @@ -0,0 +1,47 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control [monad]) + (codata [io]) + (data char + [text]) + (math ["R" random]) + pipe + [host #- try]) + lux/test) + +(test: "Char operations" + [value R;char] + (assert "" (and (:: Eq<Char> = value value) + (|> value code char (:: Eq<Char> = value)) + (|> value + (:: Codec<Text,Char> encode) + (:: Codec<Text,Char> decode) + (case> (#;Right dec-value) + (:: Eq<Char> = value dec-value) + + (#;Left _) + false)) + (|> value as-text + (text;at +0) (default (undefined)) + (:: Eq<Char> = value)) + (|> value as-text text;upper-case + (text;at +0) (default (undefined)) + (:: Ord<Char> <= value)) + (|> value as-text text;lower-case + (text;at +0) (default (undefined)) + (:: Ord<Char> >= value)) + ))) + +(test: "Special cases" + (all (assert "" (space? #" ")) + (assert "" (space? #"\n")) + (assert "" (space? #"\t")) + (assert "" (space? #"\r")) + (assert "" (space? #"\f")) + (assert "" (not (space? #"a"))) + )) diff --git a/stdlib/test/test/lux/data/error.lux b/stdlib/test/test/lux/data/error.lux new file mode 100644 index 000000000..a1d2cb6ff --- /dev/null +++ b/stdlib/test/test/lux/data/error.lux @@ -0,0 +1,42 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data error)) + lux/test) + +(test: "lux/data/error exports" + (all (match (#;Right 11) + (:: Functor<Error> map inc (: (Error Int) + (#;Right 10)))) + (match (#;Left "YOLO") + (:: Functor<Error> map inc (: (Error Int) + (#;Left "YOLO")))) + + (match (#;Right 20) + (:: Applicative<Error> wrap 20)) + (match (#;Right 11) + (let [(^open) Applicative<Error>] + (apply (wrap inc) (wrap 10)))) + (match (#;Left "YOLO") + (let [(^open) Applicative<Error>] + (apply (wrap inc) (#;Left "YOLO")))) + + (match (#;Right 30) + (do Monad<Error> + [f (wrap +) + a (wrap 10) + b (wrap 20)] + (wrap (f a b)))) + (match (#;Left "YOLO") + (do Monad<Error> + [f (wrap +) + a (#;Left "YOLO") + b (wrap 20)] + (wrap (f a b)))) + )) diff --git a/stdlib/test/test/lux/data/format/json.lux b/stdlib/test/test/lux/data/format/json.lux new file mode 100644 index 000000000..78b0b1a76 --- /dev/null +++ b/stdlib/test/test/lux/data/format/json.lux @@ -0,0 +1,314 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data [text "Text/" Monoid<Text>] + text/format + error + (format [json #* "JSON/" Eq<JSON> Codec<Text,JSON>]) + (struct [vector #+ vector] + [dict])) + [compiler #+ with-gensyms] + (macro [ast] + [syntax #+ syntax:] + [poly #+ derived:]) + [pipe] + test) + ) + +## [Utils] +(syntax: (reads-to-itself expr) + (with-gensyms [g!json g!parsed g!message] + (wrap (list (` (: (Test Unit) + (let [(~ g!json) (~ expr)] + (case (|> (~ g!json) JSON/encode JSON/decode) + (#;Left (~ g!message)) + (fail (~ g!message)) + + (#;Right (~ g!parsed)) + (if (JSON/= (~ g!json) (~ g!parsed)) + (~ (' (:: Monad<Test> wrap []))) + (fail (format "Expression does not parse to itself: " (~ (ast;text (ast;ast-to-text expr))) + "\n\nWhich is: " (|> (~ g!json) JSON/encode) + "\n\nInstead, it parsed to: " (JSON/encode (~ g!parsed)))) + )))) + ))))) + +## [Tests] +## (derived: (Codec<JSON,?> ;Bool)) +## (derived: (Codec<JSON,?> ;Int)) +## (derived: (Codec<JSON,?> ;Real)) +## (derived: (Codec<JSON,?> ;Char)) +## (derived: (Codec<JSON,?> ;Text)) + +## (type: Int-List (List Int)) +## (derived: (Codec<JSON,?> ;;Int-List)) + +## (type: Int-Maybe (Maybe Int)) +## (derived: (Codec<JSON,?> ;;Int-Maybe)) + +## (type: Triple [Bool Int Text]) +## (derived: (Codec<JSON,?> ;;Triple)) + +## (type: User +## {#alive? Bool +## #age Int +## #name Text}) +## (derived: (Codec<JSON,?> ;;User)) + +## (type: Options +## (#One Bool) +## (#Two Int) +## (#Three Text)) +## (derived: (Codec<JSON,?> ;;Options)) + +## (test: "Auto-generated codecs" +## (let% [<tests> (do-template [<input> <output> <codec>] +## [(match <output> +## (|> <input> +## (:: <codec> encode) +## JSON/encode)) +## (match+ <input> +## (should-pass (|> (JSON/decode <output>) +## (pipe;%> Error/Monad +## [(:: <codec> decode)]))))] + +## [true "true" Codec<JSON,Bool>] +## [123 "123.0" Codec<JSON,Int>] +## [123.45 "123.45" Codec<JSON,Real>] +## [#"a" "\"a\"" Codec<JSON,Char>] +## ["yolo" "\"yolo\"" Codec<JSON,Text>] + +## [(#;Cons 1 (#;Cons 2 (#;Cons 3 #;Nil))) "[1.0,2.0,3.0]" Codec<JSON,Int-List>] +## [#;Nil "[]" Codec<JSON,Int-List>] +## [(#;Some 1) "1.0" Codec<JSON,Int-Maybe>] +## [#;None "null" Codec<JSON,Int-Maybe>] +## [[false 456 "lol"] "[false,456.0,\"lol\"]" Codec<JSON,Triple>] +## [{#alive? true #age 25 #name "Eduardo Julian"} +## "{\"alive?\":true,\"age\":25.0,\"name\":\"Eduardo Julian\"}" +## Codec<JSON,User>] +## [(#One true) "[\"One\",true]" Codec<JSON,Options>] +## [(#Two 123) "[\"Two\",123.0]" Codec<JSON,Options>] +## [(#Three "yolo") "[\"Three\",\"yolo\"]" Codec<JSON,Options>] +## )] +## (test-all <tests> +## ))) + +(test: "Basics" + (test-all (match #json;Null + null) + + (match (#json;Boolean true) + (gen-boolean true)) + + (match (#json;Boolean false) + (gen-boolean false)) + + (match (#json;Number 123.45) + (gen-number 123.45)) + + (match (#json;String "YOLO") + (gen-string "YOLO")) + + ## (match (^ (#json;Array (list (#json;Boolean true) (#json;Number 123.45) (#json;String "YOLO")))) + ## (json [(gen-boolean true) (gen-number 123.45) (gen-string "YOLO")])) + + ## (match (^ (#json;Object (list ["yolo" (#json;Boolean true)] + ## ["lol" (#json;Number 123.45)]))) + ## (json {"yolo" (gen-boolean true) + ## "lol" (gen-number 123.45)})) + + (match (#;Some (#json;Boolean true)) + (get "yolo" (json {"yolo" true + "lol" 123.45}))) + + (match (#;Left _) + (get "yolo" (json {}))) + + ## (match (^ (#;Some (#json;Object (list ["lol" (#json;Number 123.45)] + ## ["yolo" (#json;Boolean true)])))) + ## (|> (json {"yolo" (gen-boolean true)}) + ## (set "lol" (gen-number 123.45)))) + + (match (#;Right true) + (get-boolean "value" (json {"value" true}))) + + (match (#;Right 123.45) + (get-number "value" (json {"value" 123.45}))) + + (match (#;Right "YOLO") + (get-string "value" (json {"value" "YOLO"}))) + + ## (match (^ (#;Right (list (#json;Boolean true) (#json;Number 123.45) (#json;String "YOLO")))) + ## (get-array "value" (json {"value" (json [(gen-boolean true) + ## (gen-number 123.45) + ## (gen-string "YOLO")])}))) + + ## (match (^ (#;Right (list ["yolo" (#json;Boolean true)] + ## ["lol" (#json;Number 123.45)]))) + ## (get-object "value" (json {"value" (json {"yolo" (gen-boolean true) + ## "lol" (gen-number 123.45)})}))) + + (match (#;Left _) + (get-array "value" (json {}))) + + (match (#;Left _) + (get-array "value" (gen-boolean true))) + )) + +(test: "Encoding" + (test-all (match "null" + (JSON/encode (json #null))) + + (match "123.0" + (JSON/encode (json 123))) + + (match "123.46" + (JSON/encode (json 123.46))) + + (match "true" + (JSON/encode (json true))) + + (match "false" + (JSON/encode (json false))) + + (match "\"YOLO\"" + (JSON/encode (json "YOLO"))) + + (match "[null,123.46,true,\"YOLO\",[\"nyan\",\"cat\"]]" + (JSON/encode (json [#null 123.46 true "YOLO" ["nyan" "cat"]]))) + + (match "{\"foo\":\"bar\",\"baz\":null,\"quux\":[\"nyan\",{\"cat\":\"meme\"}]}" + (JSON/encode (json {"foo" "bar" + "baz" #null + "quux" ["nyan" {"cat" "meme"}]}))) + )) + +(test: "Decoding" + (test-all (reads-to-itself (json #null)) + (reads-to-itself (json 123)) + (reads-to-itself (json 123.46)) + (reads-to-itself (json true)) + (reads-to-itself (json false)) + (reads-to-itself (json "\tY\"OLO\n")) + (reads-to-itself (json [#null 123.46 true "YOLO" ["nyan" "cat"]])) + (reads-to-itself (json {"foo" "bar" + "baz" #null + "quux" ["nyan" {"cat" "meme"}]})) + )) + +(test: "Parser" + (test-all (should-pass (run unit + (json #null))) + (should-fail (run unit + (json 123))) + + (match+ 123.45 + (should-pass (run real + (json 123.45)))) + (should-fail (run real + (json #null))) + + (match+ 123 + (should-pass (run int + (json 123)))) + (should-fail (run int + (json #null))) + + (match+ true + (should-pass (run bool + (json true)))) + (should-fail (run bool + (json 123))) + + (match+ "YOLO" + (should-pass (run text + (json "YOLO")))) + (should-fail (run text + (json 123))) + + (match+ (^ (list "YOLO" "LOL" "MEME")) + (should-pass (run (array text) + (json ["YOLO" "LOL" "MEME"])))) + (should-fail (run (array text) + (json 123))) + + (match+ "LOL" + (should-pass (run (at +1 text) + (json ["YOLO" "LOL" "MEME"])))) + (should-fail (run (array text) + (json 123))) + + (match+ "MEME" + (should-pass (run (field "baz" text) + (json {"foo" "YOLO" + "bar" "LOL" + "baz" "MEME"})))) + (should-fail (run (field "baz" text) + (json 123))) + + (match+ (#json;Number 123.0) + (should-pass (run any + (json 123)))) + + (match+ ["YOLO" "MEME"] + (should-pass (run (seq (field "foo" text) + (field "baz" text)) + (json {"foo" "YOLO" + "bar" "LOL" + "baz" "MEME"})))) + (should-fail (run (seq (field "foo" text) + (field "baz" text)) + (json {"foo" "YOLO" + "bar" "LOL"}))) + + (match+ (#;Left "YOLO") + (should-pass (run (alt (field "foo" text) + (field "baz" text)) + (json {"foo" "YOLO" + "bar" "LOL" + "baz" "MEME"})))) + (match+ (#;Right "MEME") + (should-pass (run (alt (field "fool" text) + (field "baz" text)) + (json {"foo" "YOLO" + "bar" "LOL" + "baz" "MEME"})))) + (should-fail (run (alt (field "fool" text) + (field "baz" text)) + (json {"foo" "YOLO" + "bar" "LOL"}))) + + (match+ "YOLO" + (should-pass (run (either (field "foo" text) + (field "baz" text)) + (json {"foo" "YOLO" + "bar" "LOL" + "baz" "MEME"})))) + (match+ "MEME" + (should-pass (run (either (field "fool" text) + (field "baz" text)) + (json {"foo" "YOLO" + "bar" "LOL" + "baz" "MEME"})))) + (should-fail (run (either (field "fool" text) + (field "baz" text)) + (json {"foo" "YOLO" + "bar" "LOL"}))) + + (match+ (#;Some "YOLO") + (should-pass (run (opt (field "foo" text)) + (json {"foo" "YOLO" + "bar" "LOL" + "baz" "MEME"})))) + (match+ #;None + (should-pass (run (opt (field "fool" text)) + (json {"foo" "YOLO" + "bar" "LOL" + "baz" "MEME"})))) + )) diff --git a/stdlib/test/test/lux/data/ident.lux b/stdlib/test/test/lux/data/ident.lux new file mode 100644 index 000000000..8cb85175f --- /dev/null +++ b/stdlib/test/test/lux/data/ident.lux @@ -0,0 +1,53 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data ["&" ident] + [text "Text/" Eq<Text>]) + (math ["R" random]) + pipe) + lux/test) + +(test: "Idents" + [## First Ident + sizeM1 (|> R;nat (:: @ map (%+ +100))) + sizeN1 (|> R;nat (:: @ map (%+ +100))) + module1 (R;text sizeM1) + name1 (R;text sizeN1) + #let [ident1 [module1 name1]] + ## Second Ident + sizeM2 (|> R;nat (:: @ map (%+ +100))) + sizeN2 (|> R;nat (:: @ map (%+ +100))) + module2 (R;text sizeM2) + name2 (R;text sizeN2) + #let [ident2 [module2 name2]] + #let [(^open "&/") &;Eq<Ident> + (^open "&/") &;Codec<Text,Ident>]] + (all (assert "Can get the module & name parts of an ident." + (and (== module1 (&;module ident1)) + (== name1 (&;name ident1)))) + + (assert "Can compare idents for equality." + (and (&/= ident1 ident1) + (if (&/= ident1 ident2) + (and (Text/= module1 module2) + (Text/= name1 name2)) + (or (not (Text/= module1 module2)) + (not (Text/= name1 name2)))))) + + (assert "Can encode idents as text." + (|> ident1 + &/encode &/decode + (case> (#;Right dec-ident) (&/= ident1 dec-ident) + _ false))) + + (assert "Encoding an ident without a module component results in text equal to the name of the ident." + (if (text;empty? module1) + (Text/= name1 (&/encode ident1)) + true)) + )) diff --git a/stdlib/test/test/lux/data/identity.lux b/stdlib/test/test/lux/data/identity.lux new file mode 100644 index 000000000..f492a801e --- /dev/null +++ b/stdlib/test/test/lux/data/identity.lux @@ -0,0 +1,36 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad + comonad) + (data identity + [text "Text/" Monoid<Text>])) + lux/test) + +(test: "lux/data/identity exports" + (all (match "yololol" (:: Functor<Identity> map (Text/append "yolo") "lol")) + + (match "yolo" (:: Applicative<Identity> wrap "yolo")) + (match "yololol" (let [(^open) Applicative<Identity>] + (apply (wrap (Text/append "yolo")) (wrap "lol")))) + + (match "yololol" + (do Monad<Identity> + [f (wrap Text/append) + a (wrap "yolo") + b (wrap "lol")] + (wrap (f a b)))) + + (match "yololol" (:: CoMonad<Identity> unwrap "yololol")) + (match "yololol" + (be CoMonad<Identity> + [f Text/append + a "yolo" + b "lol"] + (f a b))) + )) diff --git a/stdlib/test/test/lux/data/log.lux b/stdlib/test/test/lux/data/log.lux new file mode 100644 index 000000000..c052a29da --- /dev/null +++ b/stdlib/test/test/lux/data/log.lux @@ -0,0 +1,32 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data log + [text "Text/" Monoid<Text>] + [number]) + (codata function)) + lux/test) + +(test: "lux/data/log exports" + (all (match ["" 11] + (:: Functor<Log> map inc ["" 10])) + (match ["" 20] + (:: (Applicative<Log> text;Monoid<Text>) wrap 20)) + (match ["" 30] + (let [(^open) (Applicative<Log> text;Monoid<Text>)] + (apply (wrap (+ 10)) (wrap 20)))) + (match ["" 30] + (do (Monad<Log> text;Monoid<Text>) + [f (wrap +) + a (wrap 10) + b (wrap 20)] + (wrap (f a b)))) + (match ["YOLO" []] + (log "YOLO")) + )) diff --git a/stdlib/test/test/lux/data/maybe.lux b/stdlib/test/test/lux/data/maybe.lux new file mode 100644 index 000000000..bd44593d7 --- /dev/null +++ b/stdlib/test/test/lux/data/maybe.lux @@ -0,0 +1,49 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data maybe + [text "Text/" Monoid<Text>] + [number])) + lux/test) + +(test: "lux/data/maybe exports" + (all (match #;None (:: Monoid<Maybe> unit)) + (match (#;Some "yolo") (:: Monoid<Maybe> append (#;Some "yolo") (#;Some "lol"))) + (match (#;Some "yolo") (:: Monoid<Maybe> append (#;Some "yolo") #;None)) + (match (#;Some "lol") (:: Monoid<Maybe> append #;None (#;Some "lol"))) + (match #;None (: (Maybe Text) (:: Monoid<Maybe> append #;None #;None))) + + (match #;None (:: Functor<Maybe> map (Text/append "yolo") #;None)) + (match (#;Some "yololol") (:: Functor<Maybe> map (Text/append "yolo") (#;Some "lol"))) + + (match (#;Some "yolo") (:: Applicative<Maybe> wrap "yolo")) + (match (#;Some "yololol") + (let [(^open) Applicative<Maybe>] + (apply (wrap (Text/append "yolo")) (wrap "lol")))) + + (match (#;Some "yololol") + (do Monad<Maybe> + [f (wrap Text/append) + a (wrap "yolo") + b (wrap "lol")] + (wrap (f a b)))) + + (match true (:: (Eq<Maybe> text;Eq<Text>) = + (: (Maybe Text) #;None) + (: (Maybe Text) #;None))) + (match true (:: (Eq<Maybe> text;Eq<Text>) = + (#;Some "yolo") + (#;Some "yolo"))) + (match false (:: (Eq<Maybe> text;Eq<Text>) = + (#;Some "yolo") + (#;Some "lol"))) + (match false (:: (Eq<Maybe> text;Eq<Text>) = + (#;Some "yolo") + (: (Maybe Text) #;None))) + )) diff --git a/stdlib/test/test/lux/data/number.lux b/stdlib/test/test/lux/data/number.lux new file mode 100644 index 000000000..adefb480a --- /dev/null +++ b/stdlib/test/test/lux/data/number.lux @@ -0,0 +1,135 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data number + [text "Text/" Monoid<Text>] + text/format) + (math ["R" random]) + pipe) + lux/test) + +(do-template [category rand-gen <Eq> <Ord>] + [(test: (format "[" category "] " "Eq & Ord") + [x rand-gen + y rand-gen] + (assert "" (and (:: <Eq> = x x) + (or (:: <Eq> = x y) + (:: <Ord> < y x) + (:: <Ord> > y x)))))] + + ["Nat" R;nat Eq<Nat> Ord<Nat>] + ["Int" R;int Eq<Int> Ord<Int>] + ["Real" R;real Eq<Real> Ord<Real>] + ["Frac" R;frac Eq<Frac> Ord<Frac>] + ) + +(do-template [category rand-gen <Number>] + [(test: (format "[" category "] " "Number") + [x rand-gen] + (assert "" (let [(^open) <Number>] + (and (>= x (abs x)) + (<= x (negate (abs x))) + (= x (* (signum x) + (abs x)))))))] + + ["Nat" R;nat Number<Nat>] + ["Int" R;int Number<Int>] + ["Real" R;real Number<Real>] + ) + +(do-template [category rand-gen <Enum> <Number>] + [(test: (format "[" category "] " "Enum") + [x rand-gen] + (assert "" (let [(^open) <Number>] + (and (> x + (:: <Enum> succ x)) + (< x + (:: <Enum> pred x)) + + (= x + (|> x (:: <Enum> pred) (:: <Enum> succ))) + (= x + (|> x (:: <Enum> succ) (:: <Enum> pred))) + ))))] + + ["Nat" R;nat Enum<Nat> Number<Nat>] + ["Int" R;int Enum<Int> Number<Int>] + ) + +(do-template [category rand-gen <Number> <Bounded>] + [(test: (format "[" category "] " "Bounded") + [x rand-gen] + (assert "" (let [(^open) <Number>] + (and (<= x (:: <Bounded> bottom)) + (>= x (:: <Bounded> top)) + ))))] + + ["Nat" R;nat Number<Nat> Bounded<Nat>] + ["Int" R;int Number<Int> Bounded<Int>] + ["Real" R;real Number<Real> Bounded<Real>] + ) + +(do-template [category rand-gen <Number> <Monoid> <cap>] + [(test: (format "[" category "] " "Monoid") + [x (:: @ map (|>. (:: <Number> abs) <cap>) rand-gen)] + (assert "" (let [(^open) <Number> + (^open) <Monoid>] + (and (= x (append unit x)) + (= x (append x unit)) + (= unit (append unit unit)) + (>= x (append x x))))))] + + ["Nat/Add" R;nat Number<Nat> Add@Monoid<Nat> (;%+ +1000)] + ["Nat/Mul" R;nat Number<Nat> Mul@Monoid<Nat> (;%+ +1000)] + ["Nat/Min" R;nat Number<Nat> Min@Monoid<Nat> (;%+ +1000)] + ["Nat/Max" R;nat Number<Nat> Max@Monoid<Nat> (;%+ +1000)] + ["Int/Add" R;int Number<Int> Add@Monoid<Int> (;% 1000)] + ["Int/Mul" R;int Number<Int> Mul@Monoid<Int> (;% 1000)] + ["Int/Min" R;int Number<Int> Min@Monoid<Int> (;% 1000)] + ["Int/Max" R;int Number<Int> Max@Monoid<Int> (;% 1000)] + ["Real/Add" R;real Number<Real> Add@Monoid<Real> (;%. 1000.0)] + ["Real/Mul" R;real Number<Real> Mul@Monoid<Real> (;%. 1000.0)] + ["Real/Min" R;real Number<Real> Min@Monoid<Real> (;%. 1000.0)] + ["Real/Max" R;real Number<Real> Max@Monoid<Real> (;%. 1000.0)] + ) + +(do-template [category rand-gen <Number> <Codec>] + [(test: (format "[" category "] " "Codec") + [x rand-gen] + (assert "" (|> x + (:: <Codec> encode) + (:: <Codec> decode) + (case> (#;Right x') + (:: <Number> = x x') + + (#;Left _) + false))))] + + ["Nat" R;nat Number<Nat> Codec<Text,Nat>] + ["Int" R;int Number<Int> Codec<Text,Int>] + ["Real" R;real Number<Real> Codec<Text,Real>] + ## ["Frac" R;frac Number<Frac> Codec<Text,Frac>] + ) + +(do-template [category rand-gen <Number> <Codec>] + [(test: (format "[" category "] " "Alternative formats") + [x rand-gen] + (assert "" (|> x + (:: <Codec> encode) + (:: <Codec> decode) + (case> (#;Right x') + (:: <Number> = x x') + + (#;Left _) + false))))] + + ["Nat/Binary" R;nat Number<Nat> Binary@Codec<Text,Nat>] + ["Nat/Octal" R;nat Number<Nat> Octal@Codec<Text,Nat>] + ["Nat/Hex" R;nat Number<Nat> Hex@Codec<Text,Nat>] + ) diff --git a/stdlib/test/test/lux/data/product.lux b/stdlib/test/test/lux/data/product.lux new file mode 100644 index 000000000..51c23e47d --- /dev/null +++ b/stdlib/test/test/lux/data/product.lux @@ -0,0 +1,20 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data product + [text "Text/" Monoid<Text>] + [number]) + (codata function)) + lux/test) + +(test: "Product operations" + (all (match 1 (left [1 2])) + (match 2 (right [1 2])) + (match [2 1] (swap [1 2])) + )) diff --git a/stdlib/test/test/lux/data/struct/array.lux b/stdlib/test/test/lux/data/struct/array.lux new file mode 100644 index 000000000..171631bd9 --- /dev/null +++ b/stdlib/test/test/lux/data/struct/array.lux @@ -0,0 +1,130 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control [monad]) + (codata [io]) + (data (struct ["&" array] + [list]) + [number]) + (math ["R" random]) + pipe) + lux/test) + +(def: bounded-size + (R;Random Nat) + (|> R;nat + (:: R;Monad<Random> map (|>. (%+ +100) (++ +1))))) + +(test: "Arrays and their copies" + [size bounded-size + original (R;array size R;nat) + #let [clone (&;clone original) + copy (: (&;Array Nat) + (&;new size)) + manual-copy (: (&;Array Nat) + (&;new size))]] + (all (assert "Size function must correctly return size of array." + (=+ size (&;size original))) + (assert "Cloning an array should yield and identical array, but not the same one." + (and (:: (&;Eq<Array> number;Eq<Nat>) = original clone) + (not (== original clone)))) + (assert "Full-range manual copies should give the same result as cloning." + (exec (&;copy size +0 original +0 copy) + (and (:: (&;Eq<Array> number;Eq<Nat>) = original copy) + (not (== original copy))))) + (assert "Array folding should go over all values." + (exec (:: &;Fold<Array> fold + (lambda [x idx] + (exec (&;put idx x manual-copy) + (inc+ idx))) + +0 + original) + (:: (&;Eq<Array> number;Eq<Nat>) = original manual-copy))) + (assert "Transformations between (full) arrays and lists shouldn't cause lose or change any values." + (|> original + &;to-list &;from-list + (:: (&;Eq<Array> number;Eq<Nat>) = original))) + )) + +(test: "Array mutation" + [size bounded-size + idx (:: @ map (%+ size) R;nat) + array (|> (R;array size R;nat) + (R;filter (|>. &;to-list (list;any? odd?+)))) + #let [value (default (undefined) + (&;get idx array))]] + (all (assert "Shouldn't be able to find a value in an unoccupied cell." + (case (&;get idx (&;remove idx array)) + (#;Some _) false + #;None true)) + (assert "You should be able to access values put into the array." + (case (&;get idx (&;put idx value array)) + (#;Some value') (=+ value' value) + #;None false)) + (assert "All cells should be occupied on a full array." + (and (=+ size (&;occupied array)) + (=+ +0 (&;vacant array)))) + (assert "Filtering mutates the array to remove invalid values." + (exec (&;filter even?+ array) + (and (<+ size (&;occupied array)) + (>+ +0 (&;vacant array)) + (=+ size (++ (&;occupied array) + (&;vacant array)))))) + )) + +(test: "Finding values." + [size bounded-size + array (|> (R;array size R;nat) + (R;filter (|>. &;to-list (list;any? even?+))))] + (all (assert "Can find values inside arrays." + (|> (&;find even?+ array) + (case> (#;Some _) true + #;None false))) + (assert "Can find values inside arrays (with access to indices)." + (|> (&;find+ (lambda [idx n] + (and (even?+ n) + (<+ size idx))) + array) + (case> (#;Some _) true + #;None false))))) + +(test: "Functor" + [size bounded-size + array (R;array size R;nat)] + (let [(^open) &;Functor<Array> + (^open) (&;Eq<Array> number;Eq<Nat>)] + (all (assert "Functor shouldn't alter original array." + (let [copy (map id array)] + (and (= array copy) + (not (== array copy))))) + (assert "Functor should go over all available array elements." + (let [there (map inc+ array) + back-again (map dec+ there)] + (and (not (= array there)) + (= array back-again))))))) + +(test: "Monoid" + [sizeL bounded-size + sizeR bounded-size + left (R;array sizeL R;nat) + right (R;array sizeR R;nat) + #let [(^open) &;Monoid<Array> + (^open) (&;Eq<Array> number;Eq<Nat>) + fusion (append left right)]] + (all (assert "Appending two arrays should produce a new one twice as large." + (=+ (++ sizeL sizeR) (&;size fusion))) + (assert "First elements of fused array should equal the first array." + (|> (: (&;Array Nat) + (&;new sizeL)) + (&;copy sizeL +0 fusion +0) + (= left))) + (assert "Last elements of fused array should equal the second array." + (|> (: (&;Array Nat) + (&;new sizeR)) + (&;copy sizeR sizeL fusion +0) + (= right))) + )) diff --git a/stdlib/test/test/lux/data/struct/dict.lux b/stdlib/test/test/lux/data/struct/dict.lux new file mode 100644 index 000000000..06b9550aa --- /dev/null +++ b/stdlib/test/test/lux/data/struct/dict.lux @@ -0,0 +1,136 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad + [eq]) + (data [text "Text/" Monoid<Text>] + text/format + [number] + [char] + (struct ["&" dict] + [list "List/" Fold<List> Functor<List>])) + (codata function) + (math ["R" random]) + pipe) + lux/test) + +(test: "Dictionaries." + [#let [capped-nat (:: R;Monad<Random> map (%+ +100) R;nat)] + size capped-nat + dict (R;dict char;Hash<Char> size R;char capped-nat) + non-key (|> R;char + (R;filter (lambda [key] (not (&;contains? key dict))))) + test-val (|> R;nat + (R;filter (lambda [val] (not (list;member? number;Eq<Nat> (&;values dict) val)))))] + (all (assert "Size function should correctly represent Dict size." + (=+ size (&;size dict))) + + (assert "Dicts of size 0 should be considered empty." + (if (=+ +0 size) + (&;empty? dict) + (not (&;empty? dict)))) + + (assert "The functions 'entries', 'keys' and 'values' should be synchronized." + (:: (list;Eq<List> (eq;conj char;Eq<Char> number;Eq<Nat>)) = + (&;entries dict) + (list;zip2 (&;keys dict) + (&;values dict)))) + + (assert "Dict should be able to recognize it's own keys." + (list;every? (lambda [key] (&;contains? key dict)) + (&;keys dict))) + + (assert "Should be able to get every key." + (list;every? (lambda [key] (case (&;get key dict) + (#;Some _) true + _ false)) + (&;keys dict))) + + (assert "Shouldn't be able to access non-existant keys." + (case (&;get non-key dict) + (#;Some _) false + _ true)) + + (assert "Should be able to put and then get a value." + (case (&;get non-key (&;put non-key test-val dict)) + (#;Some v) (=+ test-val v) + _ true)) + + (assert "Should be able to put~ and then get a value." + (case (&;get non-key (&;put~ non-key test-val dict)) + (#;Some v) (=+ test-val v) + _ true)) + + (assert "Shouldn't be able to put~ an existing key." + (or (=+ +0 size) + (let [first-key (|> dict &;keys list;head (default (undefined)))] + (case (&;get first-key (&;put~ first-key test-val dict)) + (#;Some v) (not (=+ test-val v)) + _ true)))) + + (assert "Removing a key should make it's value inaccessible." + (let [base (&;put non-key test-val dict)] + (and (&;contains? non-key base) + (not (&;contains? non-key (&;remove non-key base)))))) + + (assert "Should be possible to update values via their keys." + (let [base (&;put non-key test-val dict) + updt (&;update non-key inc+ base)] + (case [(&;get non-key base) (&;get non-key updt)] + [(#;Some x) (#;Some y)] + (=+ (inc+ x) y) + + _ + false))) + + (assert "Additions and removals to a Dict should affect its size." + (let [plus (&;put non-key test-val dict) + base (&;remove non-key plus)] + (and (=+ (inc+ (&;size dict)) (&;size plus)) + (=+ (dec+ (&;size plus)) (&;size base))))) + + (assert "A Dict should equal itself & going to<->from lists shouldn't change that." + (let [(^open) (&;Eq<Dict> number;Eq<Nat>)] + (and (= dict dict) + (|> dict &;entries (&;from-list char;Hash<Char>) (= dict))))) + + (assert "Merging a Dict to itself changes nothing." + (let [(^open) (&;Eq<Dict> number;Eq<Nat>)] + (= dict (&;merge dict dict)))) + + (assert "If you merge, and the second dict has overlapping keys, it should overwrite yours." + (let [dict' (|> dict &;entries + (List/map (lambda [[k v]] [k (inc+ v)])) + (&;from-list char;Hash<Char>)) + (^open) (&;Eq<Dict> number;Eq<Nat>)] + (= dict' (&;merge dict' dict)))) + + (assert "Can merge values in such a way that they become combined." + (list;every? (lambda [[x x*2]] (=+ (*+ +2 x) x*2)) + (list;zip2 (&;values dict) + (&;values (&;merge-with ++ dict dict))))) + + (assert "Should be able to select subset of keys from dict." + (|> dict + (&;put non-key test-val) + (&;select (list non-key)) + &;size + (=+ +1))) + + (assert "Should be able to re-bind existing values to different keys." + (or (=+ +0 size) + (let [first-key (|> dict &;keys list;head (default (undefined))) + rebound (&;re-bind first-key non-key dict)] + (and (=+ (&;size dict) (&;size rebound)) + (&;contains? non-key rebound) + (not (&;contains? first-key rebound)) + (=+ (default (undefined) + (&;get first-key dict)) + (default (undefined) + (&;get non-key rebound))))))) + )) diff --git a/stdlib/test/test/lux/data/struct/list.lux b/stdlib/test/test/lux/data/struct/list.lux new file mode 100644 index 000000000..6baf13c6c --- /dev/null +++ b/stdlib/test/test/lux/data/struct/list.lux @@ -0,0 +1,191 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data (struct ["&" list]) + [text "Text/" Monoid<Text>] + [number] + [bool] + [product]) + (math ["R" random]) + pipe) + lux/test) + +(def: bounded-size + (R;Random Nat) + (|> R;nat + (:: R;Monad<Random> map (|>. (%+ +100) (++ +10))))) + +(test: "Lists" + [size bounded-size + idx (:: @ map (%+ size) R;nat) + sample (R;list size R;nat) + other-size bounded-size + other-sample (R;list other-size R;nat) + separator R;nat + #let [(^open) (&;Eq<List> number;Eq<Nat>) + (^open "&/") &;Functor<List>]] + (all (assert "The size function should correctly portray the size of the list." + (=+ size (&;size sample))) + + (assert "The repeat function should produce as many elements as asked of it." + (=+ size (&;size (&;repeat size [])))) + + (assert "Reversing a list does not change it's size." + (=+ (&;size sample) + (&;size (&;reverse sample)))) + + (assert "Reversing a list twice results in the original list." + (= sample + (&;reverse (&;reverse sample)))) + + (assert "Filtering by a predicate and its complement should result in a number of elements equal to the original list." + (and (=+ (&;size sample) + (++ (&;size (&;filter even?+ sample)) + (&;size (&;filter (bool;complement even?+) sample)))) + (let [[plus minus] (&;partition even?+ sample)] + (=+ (&;size sample) + (++ (&;size plus) + (&;size minus)))))) + + (assert "If every element in a list satisfies a predicate, there can't be any that satisfy its complement." + (if (&;every? even?+ sample) + (and (not (&;any? (bool;complement even?+) sample)) + (&;empty? (&;filter (bool;complement even?+) sample))) + (&;any? (bool;complement even?+) sample))) + + (assert "Any element of the list can be considered it's member." + (let [elem (default (undefined) + (&;at idx sample))] + (&;member? number;Eq<Nat> sample elem))) + + (assert "Appending the head and the tail should yield the original list." + (let [head (default (undefined) + (&;head sample)) + tail (default (undefined) + (&;tail sample))] + (= sample + (#;Cons head tail)))) + + (assert "Appending the inits and the last should yield the original list." + (let [(^open) &;Monoid<List> + inits (default (undefined) + (&;inits sample)) + last (default (undefined) + (&;last sample))] + (= sample + (append inits (list last))))) + + (assert "Functor should go over every element of the list." + (let [(^open) &;Functor<List> + there (map inc+ sample) + back-again (map dec+ there)] + (and (not (= sample there)) + (= sample back-again)))) + + (assert "Splitting a list into chunks and re-appending them should yield the original list." + (let [(^open) &;Monoid<List> + [left right] (&;split idx sample) + [left' right'] (&;split-with even?+ sample)] + (and (= sample + (append left right)) + (= sample + (append left' right')) + (= sample + (append (&;take idx sample) + (&;drop idx sample))) + (= sample + (append (&;take-while even?+ sample) + (&;drop-while even?+ sample))) + ))) + + (assert "Segmenting the list in pairs should yield as many elements as N/2." + (=+ (/+ +2 size) + (&;size (&;as-pairs sample)))) + + (assert "Sorting a list shouldn't change it's size." + (=+ (&;size sample) + (&;size (&;sort <+ sample)))) + + (assert "Sorting a list with one order should yield the reverse of sorting it with the opposite order." + (= (&;sort <+ sample) + (&;reverse (&;sort >+ sample)))) + + (assert "If you zip 2 lists, the result's size will be that of the smaller list." + (=+ (&;size (&;zip2 sample other-sample)) + (min+ (&;size sample) (&;size other-sample)))) + + (assert "I can pair-up elements of a list in order." + (let [(^open) &;Functor<List> + zipped (&;zip2 sample other-sample) + num-zipper (&;size zipped)] + (and (|> zipped (map product;left) (= (&;take num-zipper sample))) + (|> zipped (map product;right) (= (&;take num-zipper other-sample)))))) + + (assert "You can generate indices for any size, and they will be in ascending order." + (let [(^open) &;Functor<List> + indices (&;indices size)] + (and (=+ size (&;size indices)) + (= indices + (&;sort <+ indices)) + (&;every? (=+ (dec+ size)) + (&;zip2-with ++ + indices + (&;sort >+ indices))) + ))) + + (assert "The 'interpose' function places a value between every member of a list." + (let [(^open) &;Functor<List> + sample+ (&;interpose separator sample)] + (and (=+ (|> size (*+ +2) dec+) + (&;size sample+)) + (|> sample+ &;as-pairs (map product;right) (&;every? (=+ separator)))))) + + (assert "List append is a monoid." + (let [(^open) &;Monoid<List>] + (and (= sample (append unit sample)) + (= sample (append sample unit)) + (let [[left right] (&;split size (append sample other-sample))] + (and (= sample left) + (= other-sample right)))))) + + (assert "Applicative allows you to create singleton lists, and apply lists of functions to lists of values." + (let [(^open) &;Applicative<List>] + (and (= (list separator) (wrap separator)) + (= (map inc+ sample) + (apply (wrap inc+) sample))))) + + (assert "List concatenation is a monad." + (let [(^open) &;Monad<List> + (^open) &;Monoid<List>] + (= (append sample other-sample) + (join (list sample other-sample))))) + + (assert "You can find any value that satisfies some criterium, if such values exist in the list." + (case (&;find even?+ sample) + (#;Some found) + (and (even?+ found) + (&;any? even?+ sample) + (not (&;every? (bool;complement even?+) sample))) + + #;None + (and (not (&;any? even?+ sample)) + (&;every? (bool;complement even?+) sample)))) + + (assert "You can iteratively construct a list, generating values until you're done." + (= (&;range+ +0 (dec+ size)) + (&;iterate (lambda [n] (if (<+ size n) (#;Some (inc+ n)) #;None)) + +0))) + + (assert "Can enumerate all elements in a list." + (let [enum-sample (&;enumerate sample)] + (and (= (&;indices (&;size enum-sample)) + (&/map product;left enum-sample)) + (= sample + (&/map product;right enum-sample))))) + )) diff --git a/stdlib/test/test/lux/data/struct/queue.lux b/stdlib/test/test/lux/data/struct/queue.lux new file mode 100644 index 000000000..895929ab4 --- /dev/null +++ b/stdlib/test/test/lux/data/struct/queue.lux @@ -0,0 +1,54 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data (struct ["&" queue]) + [number]) + (math ["R" random]) + pipe) + lux/test) + +(test: "Queues" + [size (:: @ map (%+ +100) R;nat) + sample (R;queue size R;nat) + non-member (|> R;nat + (R;filter (. not (&;enqueued? number;Eq<Nat> sample))))] + (all (assert "I can query the size of a queue (and empty queues have size 0)." + (if (=+ +0 size) + (&;empty? sample) + (=+ size (&;size sample)))) + + (assert "Enqueueing and dequeing affects the size of queues." + (and (=+ (inc+ size) (&;size (&;enqueue non-member sample))) + (or (&;empty? sample) + (=+ (dec+ size) (&;size (&;dequeue sample)))) + (=+ size (&;size (&;dequeue (&;enqueue non-member sample)))))) + + (assert "Transforming to/from list can't change the queue." + (let [(^open "&/") (&;Eq<Queue> number;Eq<Nat>)] + (|> sample + &;to-list &;from-list + (&/= sample)))) + + (assert "I can always peek at a non-empty queue." + (case (&;peek sample) + #;None (&;empty? sample) + (#;Some _) true)) + + (assert "I can query whether an element belongs to a queue." + (and (not (&;enqueued? number;Eq<Nat> sample non-member)) + (&;enqueued? number;Eq<Nat> (&;enqueue non-member sample) + non-member) + (case (&;peek sample) + #;None + (&;empty? sample) + + (#;Some first) + (and (&;enqueued? number;Eq<Nat> sample first) + (not (&;enqueued? number;Eq<Nat> (&;dequeue sample) first)))))) + )) diff --git a/stdlib/test/test/lux/data/struct/set.lux b/stdlib/test/test/lux/data/struct/set.lux new file mode 100644 index 000000000..3725e7f93 --- /dev/null +++ b/stdlib/test/test/lux/data/struct/set.lux @@ -0,0 +1,67 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data (struct ["&" set] + [list "" Fold<List>]) + [number]) + (math ["R" random]) + pipe) + lux/test) + +(def: gen-nat + (R;Random Nat) + (|> R;nat + (:: R;Monad<Random> map (%+ +100)))) + +(test: "Sets" + [sizeL gen-nat + sizeR gen-nat + setL (R;set number;Hash<Nat> sizeL gen-nat) + setR (R;set number;Hash<Nat> sizeR gen-nat) + non-member (|> gen-nat + (R;filter (. not (&;member? setL)))) + #let [(^open "&/") &;Eq<Set>]] + (all (assert "I can query the size of a set." + (and (=+ sizeL (&;size setL)) + (=+ sizeR (&;size setR)))) + + (assert "Converting sets to/from lists can't change their values." + (|> setL + &;to-list (&;from-list number;Hash<Nat>) + (&/= setL))) + + (assert "Every set is a sub-set of the union of itself with another." + (let [setLR (&;union setL setR)] + (and (&;sub? setLR setL) + (&;sub? setLR setR)))) + + (assert "Every set is a super-set of the intersection of itself with another." + (let [setLR (&;intersection setL setR)] + (and (&;super? setLR setL) + (&;super? setLR setR)))) + + (assert "Union with the empty set leaves a set unchanged." + (&/= setL + (&;union (&;new number;Hash<Nat>) + setL))) + + (assert "Intersection with the empty set results in the empty set." + (let [empty-set (&;new number;Hash<Nat>)] + (&/= empty-set + (&;intersection empty-set setL)))) + + (assert "After substracting a set A from another B, no member of A can be a member of B." + (let [sub (&;difference setR setL)] + (not (list;any? (&;member? setL) (&;to-list setR))))) + + (assert "Every member of a set must be identifiable." + (and (not (&;member? setL non-member)) + (&;member? (&;add non-member setL) non-member) + (not (&;member? (&;remove non-member (&;add non-member setL)) non-member)))) + )) diff --git a/stdlib/test/test/lux/data/struct/stack.lux b/stdlib/test/test/lux/data/struct/stack.lux new file mode 100644 index 000000000..dc3bb1e89 --- /dev/null +++ b/stdlib/test/test/lux/data/struct/stack.lux @@ -0,0 +1,47 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data (struct ["&" stack] + [list "" Fold<List>]) + [number]) + (math ["R" random]) + pipe) + lux/test) + +(def: gen-nat + (R;Random Nat) + (|> R;nat + (:: R;Monad<Random> map (%+ +100)))) + +(test: "Stacks" + [size gen-nat + sample (R;stack size gen-nat) + new-top gen-nat] + (all (assert "Can query the size of a stack." + (=+ size (&;size sample))) + + (assert "Can peek inside non-empty stacks." + (case (&;peek sample) + #;None (&;empty? sample) + (#;Some _) (not (&;empty? sample)))) + + (assert "Popping empty stacks doesn't change anything. + But, if they're non-empty, the top of the stack is removed." + (let [sample' (&;pop sample)] + (or (=+ (&;size sample) (inc+ (&;size sample'))) + (and (&;empty? sample) (&;empty? sample'))) + )) + + (assert "Pushing onto a stack always increases it by 1, adding a new value at the top." + (and (== sample + (&;pop (&;push new-top sample))) + (=+ (inc+ (&;size sample)) (&;size (&;push new-top sample))) + (|> (&;push new-top sample) &;peek (default (undefined)) + (== new-top)))) + )) diff --git a/stdlib/test/test/lux/data/struct/tree.lux b/stdlib/test/test/lux/data/struct/tree.lux new file mode 100644 index 000000000..0595ca7b3 --- /dev/null +++ b/stdlib/test/test/lux/data/struct/tree.lux @@ -0,0 +1,39 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data (struct ["&" tree] + [list "List/" Monad<List>]) + [number]) + (math ["R" random]) + pipe) + lux/test) + +(def: gen-nat + (R;Random Nat) + (|> R;nat + (:: R;Monad<Random> map (%+ +100)))) + +(test: "Trees" + [leaf (:: @ map &;leaf R;nat) + branchS gen-nat + branchV R;nat + branchC (R;list branchS R;nat) + #let [branch (&;branch branchV (List/map &;leaf branchC))] + #let [(^open "&/") (&;Eq<Tree> number;Eq<Nat>) + (^open "List/") (list;Eq<List> number;Eq<Nat>)]] + (all (assert "Can compare trees for equality." + (and (&/= leaf leaf) + (&/= branch branch) + (not (&/= leaf branch)) + (not (&/= leaf (&;branch branchV (List/map &;leaf (list;reverse branchC))))))) + + (assert "Can flatten a tree to get all the nodes as a flat tree." + (List/= (list& branchV branchC) + (&;flatten branch))) + )) diff --git a/stdlib/test/test/lux/data/struct/vector.lux b/stdlib/test/test/lux/data/struct/vector.lux new file mode 100644 index 000000000..87f8fa4cb --- /dev/null +++ b/stdlib/test/test/lux/data/struct/vector.lux @@ -0,0 +1,84 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data (struct ["&" vector] + [list "List/" Fold<List> Functor<List>]) + [text "Text/" Monoid<Text>] + text/format + [number]) + (codata function) + (math ["R" random]) + pipe) + lux/test) + +(test: "Vectors" + [size (|> R;nat (:: @ map (%+ +100))) + idx (|> R;nat (:: @ map (%+ size))) + sample (R;vector size R;nat) + other-sample (R;vector size R;nat) + non-member (|> R;nat (R;filter (. not (&;member? number;Eq<Nat> sample)))) + #let [(^open "&/") (&;Eq<Vector> number;Eq<Nat>) + (^open "&/") &;Monad<Vector> + (^open "&/") &;Fold<Vector> + (^open "&/") &;Monoid<Vector>]] + (all (assert "Can query size of vector." + (if (&;empty? sample) + (and (=+ +0 size) + (=+ +0 (&;size sample))) + (=+ size (&;size sample)))) + + (assert "Can add and remove elements to vectors." + (and (=+ (inc+ size) + (&;size (&;add non-member sample))) + (=+ (dec+ size) + (&;size (&;pop sample))))) + + (assert "Can put and get elements into vectors." + (|> sample + (&;put idx non-member) + (&;at idx) + (default (undefined)) + (== non-member))) + + (assert "Can update elements of vectors." + (|> sample + (&;put idx non-member) + (&;update idx inc+) + (&;at idx) + (default (undefined)) + (=+ (inc+ non-member)))) + + (assert "Can safely transform to/from lists." + (|> sample + &;to-list &;from-list + (&/= sample))) + + (assert "Can identify members of a vector." + (and (not (&;member? number;Eq<Nat> sample non-member)) + (&;member? number;Eq<Nat> (&;add non-member sample) non-member))) + + (assert "Can fold over elements of vector." + (=+ (List/fold ++ +0 (&;to-list sample)) + (&/fold ++ +0 sample))) + + (assert "Functor goes over every element." + (let [there (&/map inc+ sample) + back-again (&/map dec+ there)] + (and (not (&/= sample there)) + (&/= sample back-again)))) + + (assert "Applicative allows you to create singleton vectors, and apply vectors of functions to vectors of values." + (and (&/= (&;vector non-member) (&/wrap non-member)) + (&/= (&/map inc+ sample) + (&/apply (&/wrap inc+) sample)))) + + (assert "Vector concatenation is a monad." + (&/= (&/append sample other-sample) + (&/join (&;vector sample other-sample)))) + )) diff --git a/stdlib/test/test/lux/data/struct/zipper.lux b/stdlib/test/test/lux/data/struct/zipper.lux new file mode 100644 index 000000000..a3bede88d --- /dev/null +++ b/stdlib/test/test/lux/data/struct/zipper.lux @@ -0,0 +1,127 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data (struct ["&" zipper] + [tree] + [list "List/" Fold<List> Functor<List>]) + [text "Text/" Monoid<Text>] + text/format + [number]) + (codata function) + (math ["R" random]) + pipe) + lux/test) + +(def: gen-tree + (R;Random (tree;Tree Nat)) + (R;rec (lambda [gen-tree] + (do R;Monad<Random> + ## Each branch can have, at most, 1 child. + [size (|> R;nat (:: @ map (%+ +2)))] + (R;seq R;nat + (R;list size gen-tree)))))) + +(def: (to-end zipper) + (All [a] (-> (&;Zipper a) (&;Zipper a))) + (loop [zipper zipper] + (if (&;end? zipper) + zipper + (recur (&;next zipper))))) + +(test: "Zippers" + [sample gen-tree + new-val R;nat + pre-val R;nat + post-val R;nat + #let [(^open "Tree/") (tree;Eq<Tree> number;Eq<Nat>) + (^open "List/") (list;Eq<List> number;Eq<Nat>)]] + (all (assert "Trees can be converted to/from zippers." + (|> sample + &;from-tree &;to-tree + (Tree/= sample))) + + (assert "Creating a zipper gives you a root node." + (|> sample &;from-tree &;root?)) + + (assert "Can move down inside branches. Can move up from lower nodes." + (let [zipper (&;from-tree sample)] + (if (&;branch? zipper) + (let [child (|> zipper &;down)] + (and (not (Tree/= sample (&;to-tree child))) + (|> child &;parent (default (undefined)) (== zipper)) + (|> child &;up (== zipper)) + (|> child &;root (== zipper)))) + (and (&;leaf? zipper) + (|> zipper (&;prepend-child new-val) &;branch?))))) + + (assert "Can prepend and append children." + (let [zipper (&;from-tree sample)] + (if (&;branch? zipper) + (let [mid-val (|> zipper &;down &;value) + zipper (|> zipper + (&;prepend-child pre-val) + (&;append-child post-val))] + (and (|> zipper &;down &;value (== pre-val)) + (|> zipper &;down &;right &;value (== mid-val)) + (|> zipper &;down &;right &;right &;value (== post-val)) + (|> zipper &;down &;rightmost &;leftmost &;value (== pre-val)) + (|> zipper &;down &;right &;left &;value (== mid-val)) + (|> zipper &;down &;rightmost &;value (== post-val)))) + true))) + + (assert "Can insert children around a node (unless it's root)." + (let [zipper (&;from-tree sample)] + (if (&;branch? zipper) + (let [mid-val (|> zipper &;down &;value) + zipper (|> zipper + &;down + (&;insert-left pre-val) + (default (undefined)) + (&;insert-right post-val) + (default (undefined)) + &;up)] + (and (|> zipper &;down &;value (== pre-val)) + (|> zipper &;down &;right &;value (== mid-val)) + (|> zipper &;down &;right &;right &;value (== post-val)) + (|> zipper &;down &;rightmost &;leftmost &;value (== pre-val)) + (|> zipper &;down &;right &;left &;value (== mid-val)) + (|> zipper &;down &;rightmost &;value (== post-val)))) + (and (|> zipper (&;insert-left pre-val) (case> (#;Some _) false + #;None true)) + (|> zipper (&;insert-right post-val) (case> (#;Some _) false + #;None true)))))) + + (assert "Can set and update the value of a node." + (|> sample &;from-tree (&;set new-val) &;value (=+ new-val))) + + (assert "Zipper traversal follows the outline of the tree depth-first." + (List/= (tree;flatten sample) + (loop [zipper (&;from-tree sample)] + (if (&;end? zipper) + (list) + (#;Cons (&;value zipper) + (recur (&;next zipper))))))) + + (assert "Backwards zipper traversal yield reverse tree flatten." + (List/= (list;reverse (tree;flatten sample)) + (loop [zipper (to-end (&;from-tree sample))] + (if (&;root? zipper) + (list) + (#;Cons (&;value zipper) + (recur (&;prev zipper))))))) + + (assert "Can remove nodes (except root nodes)." + (let [zipper (&;from-tree sample)] + (if (&;branch? zipper) + (and (|> zipper &;down &;root? not) + (|> zipper &;down &;remove (case> #;None false + (#;Some node) (&;root? node)))) + (|> zipper &;remove (case> #;None true + (#;Some _) false))))) + )) diff --git a/stdlib/test/test/lux/data/sum.lux b/stdlib/test/test/lux/data/sum.lux new file mode 100644 index 000000000..a23eeec00 --- /dev/null +++ b/stdlib/test/test/lux/data/sum.lux @@ -0,0 +1,32 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data sum + [text "Text/" Monoid<Text>] + [number]) + (codata function)) + lux/test) + +(test: "Sum operations" + (all (match (+0 1) (left 1)) + (match (+1 2) (right 2)) + (match (^ (list "0" "2")) + (lefts (: (List (| Text Text)) + (list (+0 "0") (+1 "1") (+0 "2"))))) + (match (^ (list "1")) + (rights (: (List (| Text Text)) + (list (+0 "0") (+1 "1") (+0 "2"))))) + (match (^ [(list "0" "2") (list "1")]) + (partition (: (List (| Text Text)) + (list (+0 "0") (+1 "1") (+0 "2"))))) + (match 10 + (either (lambda [_] 10) (lambda [_] 20) (: (| Text Text) (+0 "")))) + (match 20 + (either (lambda [_] 10) (lambda [_] 20) (: (| Text Text) (+1 "")))) + )) diff --git a/stdlib/test/test/lux/data/text.lux b/stdlib/test/test/lux/data/text.lux new file mode 100644 index 000000000..640ae3f4c --- /dev/null +++ b/stdlib/test/test/lux/data/text.lux @@ -0,0 +1,150 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data ["&" text] + [char] + text/format + [number] + (struct [list])) + (codata function) + (math ["R" random]) + pipe) + lux/test) + +(test: "Size" + [size (:: @ map (%+ +100) R;nat) + sample (R;text size)] + (assert "" (or (and (=+ +0 size) + (&;empty? sample)) + (=+ size (&;size sample))))) + +(def: bounded-size + (R;Random Nat) + (|> R;nat + (:: R;Monad<Random> map (|>. (%+ +100) (++ +1))))) + +(test: "Locations" + [size bounded-size + idx (:: @ map (%+ size) R;nat) + sample (R;text size)] + (assert "" (|> sample + (&;at idx) + (case> (^=> (#;Some char) + {(char;as-text char) char'} + {[(&;index-of char' sample) + (&;last-index-of char' sample) + (&;index-of' char' idx sample) + (&;last-index-of' char' idx sample)] + [(#;Some io) (#;Some lio) + (#;Some io') (#;Some lio')]}) + (and (<=+ idx io) + (>=+ idx lio) + + (=+ idx io') + (>=+ idx lio') + + (&;contains? char' sample)) + + _ + false + )) + )) + +(test: "Text functions" + [sizeL bounded-size + sizeR bounded-size + sampleL (R;text sizeL) + sampleR (R;text sizeR) + #let [sample (&;concat (list sampleL sampleR)) + fake-sample (&;join-with " " (list sampleL sampleR)) + dup-sample (&;join-with "" (list sampleL sampleR)) + enclosed-sample (&;enclose [sampleR sampleR] sampleL) + (^open) &;Eq<Text>]] + (assert "" (and (not (= sample fake-sample)) + (= sample dup-sample) + (&;starts-with? sampleL sample) + (&;ends-with? sampleR sample) + (= enclosed-sample + (&;enclose' sampleR sampleL)) + + (|> (&;split sizeL sample) + (case> (#;Right [_l _r]) + (and (= sampleL _l) + (= sampleR _r) + (= sample (&;concat (list _l _r)))) + + _ + false)) + + (|> [(&;sub +0 sizeL sample) + (&;sub sizeL (&;size sample) sample) + (&;sub' sizeL sample) + (&;sub' +0 sample)] + (case> [(#;Right _l) (#;Right _r) (#;Right _r') (#;Right _f)] + (and (= sampleL _l) + (= sampleR _r) + (= _r _r') + (= sample _f)) + + _ + false)) + ) + )) + +(test: "More text functions" + [sizeS bounded-size + sizeP bounded-size + sizeL bounded-size + sep1 (R;text sizeS) + sep2 (R;text sizeS) + #let [part-gen (|> (R;text sizeP) + (R;filter (. not (&;contains? sep1))))] + parts (R;list sizeL part-gen) + #let [sample1 (&;concat (list;interpose sep1 parts)) + sample2 (&;concat (list;interpose sep2 parts)) + (^open) &;Eq<Text>]] + (assert "" (and (=+ (list;size parts) + (list;size (&;split-all-with sep1 sample1))) + (= sample2 + (&;replace sep1 sep2 sample1)) + ))) + +(test: "Other text functions" + (all (match "abc" (&;lower-case "ABC")) + (match "ABC" (&;upper-case "abc")) + (match "ABC" (&;trim " \tABC\n\r")) + )) + +(test: "Structures" + (all (assert "" (:: &;Ord<Text> < "bcd" "abc")) + (assert "" (not (:: &;Ord<Text> < "abc" "abc"))) + (assert "" (not (:: &;Ord<Text> < "abc" "bcd"))) + (assert "" (:: &;Ord<Text> <= "bcd" "abc")) + (assert "" (:: &;Ord<Text> <= "abc" "abc")) + (assert "" (not (:: &;Ord<Text> <= "abc" "bcd"))) + (assert "" (:: &;Ord<Text> > "abc" "bcd")) + (assert "" (not (:: &;Ord<Text> > "abc" "abc"))) + (assert "" (not (:: &;Ord<Text> > "bcd" "abc"))) + (assert "" (:: &;Ord<Text> >= "abc" "bcd")) + (assert "" (:: &;Ord<Text> >= "abc" "abc")) + (assert "" (not (:: &;Ord<Text> >= "bcd" "abc"))) + )) + +(test: "Codec" + [size bounded-size + sample (R;text size) + #let [(^open) &;Eq<Text>]] + (assert "" (|> sample + (:: &;Codec<Text,Text> encode) + (:: &;Codec<Text,Text> decode) + (case> (#;Right decoded) + (= sample decoded) + + _ + false)))) diff --git a/stdlib/test/test/lux/data/text/format.lux b/stdlib/test/test/lux/data/text/format.lux new file mode 100644 index 000000000..cd15c8584 --- /dev/null +++ b/stdlib/test/test/lux/data/text/format.lux @@ -0,0 +1,22 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data text/format + [number]) + (codata function)) + lux/test) + +(test: "Formatters" + (all (match "true" (%b true)) + (match "123" (%i 123)) + (match "123.456" (%r 123.456)) + (match "#\"t\"" (%c #"t")) + (match "\"YOLO\"" (%t "YOLO")) + (match "User-id: 123 -- Active: true" (format "User-id: " (%i 123) " -- Active: " (%b true))) + )) diff --git a/stdlib/test/test/lux/host.lux b/stdlib/test/test/lux/host.lux new file mode 100644 index 000000000..109d8dfed --- /dev/null +++ b/stdlib/test/test/lux/host.lux @@ -0,0 +1,54 @@ +(;module: + lux + (lux (control monad) + (data text/format + [number] + [product]) + (codata function + [io]) + host) + lux/test) + +(jvm-import java.lang.Object + (new [])) + +(jvm-import java.lang.String) + +(jvm-import (java.lang.Class a) + (getName [] String)) + +(test: "lux/host exports" + (let% [<conversions-0> (do-template [<value> <forward> <backward>] + [(match <value> (|> <value> <forward> <backward>))] + + [123 l2d d2l] + [123 l2f f2l] + [123 l2i i2l] + [123.0 d2l l2d] + [123.0 d2f f2d] + [123.0 d2i i2d] + ) + <conversions-1> (do-template [<forward> <backward>] + [(match 123 (|> 123 l2i <forward> <backward> i2l))] + + [i2c c2i] + )] + (test-all (match "java.lang.Class" (Class.getName [] (class-for java.lang.Class))) + (match "java.lang.Class" (Class.getName [] (class-for Class))) + (match true (null? (: Object (null)))) + (match false (null? (Object.new []))) + (match #;None (: (Maybe Object) (??? (null)))) + (match (#;Some _) (: (Maybe Object) (??? (Object.new [])))) + (match true (null? (!!! (: (Maybe Object) (??? (null)))))) + (match false (null? (!!! (: (Maybe Object) (??? (Object.new [])))))) + (match true (instance? Object (Object.new []))) + (match false (instance? String (Object.new []))) + (match 123 (synchronized (Object.new []) + 123)) + (match +10 (array-length (array String +10))) + (match "YOLO" (let [array (array String +10)] + (exec (array-store +0 "YOLO" array) + (array-load +0 array)))) + <conversions-0> + <conversions-1> + ))) diff --git a/stdlib/test/test/lux/lexer.lux b/stdlib/test/test/lux/lexer.lux new file mode 100644 index 000000000..d0b17fe4b --- /dev/null +++ b/stdlib/test/test/lux/lexer.lux @@ -0,0 +1,133 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + [lux #- not] + (lux (control monad) + (codata [io]) + (data error) + [test #- fail assert] + lexer)) + +## [Tests] +(test: "Lexer end works" + (test-all (should-pass (run end "")) + (should-fail (run end "YOLO")))) + +(test: "Simple text lexers" + (test-all (match (#;Right "YO") + (run (this "YO") "YOLO")) + (should-fail (run (this "YO") "MEME")))) + +(test: "Char lexers" + (test-all (match (#;Right #"Y") + (run (this-char #"Y") "YOLO")) + (should-fail (run (this-char #"Y") "MEME")) + (match (#;Right #"Y") + (run (char-range #"X" #"Z") "YOLO")) + (should-fail (run (char-range #"X" #"Z") "MEME")) + (match (#;Right #"Y") + (run upper "YOLO")) + (should-fail (run upper "meme")) + (match (#;Right #"y") + (run lower "yolo")) + (should-fail (run lower "MEME")) + (match (#;Right #"1") + (run digit "1")) + (should-fail (run digit " ")) + (match (#;Right #"7") + (run oct-digit "7")) + (should-fail (run oct-digit "8")) + (match (#;Right #"A") + (run any "A")) + (should-fail (run any "")))) + +(test: "Combinators" + (test-all (match (#;Right [#"Y" #"O"]) + (run (seq any any) "YOLO")) + (should-fail (run (seq any any) "Y")) + (match+ (#;Left #"0") + (should-pass (run (alt digit upper) "0"))) + (match+ (#;Right #"A") + (should-pass (run (alt digit upper) "A"))) + (should-fail (run (alt digit upper) "a")) + (should-pass (run (not (alt digit upper)) "a")) + (should-fail (run (not (alt digit upper)) "A")) + (match (#;Right #"0") + (run (either digit upper) "0")) + (match (#;Right #"A") + (run (either digit upper) "A")) + (should-fail (run (either digit upper) "a")) + (match (#;Right #"A") + (run alpha "A")) + (match (#;Right #"a") + (run alpha "a")) + (should-fail (run alpha "1")) + (match (#;Right #"A") + (run alpha-num "A")) + (match (#;Right #"a") + (run alpha-num "a")) + (match (#;Right #"1") + (run alpha-num "1")) + (should-fail (run alpha-num " ")) + (match (#;Right #"1") + (run hex-digit "1")) + (match (#;Right #"a") + (run hex-digit "a")) + (match (#;Right #"A") + (run hex-digit "A")) + (should-fail (run hex-digit " ")) + (match (#;Right #" ") + (run space " ")) + (should-fail (run space "8")) + (match (#;Right #"C") + (run (one-of "ABC") "C")) + (should-fail (run (one-of "ABC") "D")) + (match (#;Right #"D") + (run (none-of "ABC") "D")) + (should-fail (run (none-of "ABC") "C")) + (match (#;Right #"D") + (run (satisfies (lambda [c] true)) "D")) + (should-fail (run (satisfies (lambda [c] false)) "C")) + (match (#;Right "0123456789ABCDEF") + (run (many' hex-digit) "0123456789ABCDEF yolo")) + (should-fail (run (many' hex-digit) "yolo")) + (match (#;Right "") + (run (some' hex-digit) "yolo")) + )) + +(test: "Yet more combinators..." + (test-all (should-fail (run (fail "Well, it really SHOULD fail...") "yolo")) + (should-fail (run (assert false "Well, it really SHOULD fail...") "yolo")) + (should-pass (run (assert true "GO, GO, GO!") "yolo")) + (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F"))) + (run (many hex-digit) "0123456789ABCDEF yolo")) + (should-fail (run (many hex-digit) "yolo")) + (match (^ (#;Right (list))) + (run (some hex-digit) "yolo")) + (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F"))) + (run (exactly +16 hex-digit) "0123456789ABCDEF yolo")) + (match (^ (#;Right (list #"0" #"1" #"2"))) + (run (exactly +3 hex-digit) "0123456789ABCDEF yolo")) + (should-fail (run (exactly +17 hex-digit) "0123456789ABCDEF yolo")) + (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F"))) + (run (at-most +16 hex-digit) "0123456789ABCDEF yolo")) + (match (^ (#;Right (list #"0" #"1" #"2"))) + (run (at-most +3 hex-digit) "0123456789ABCDEF yolo")) + (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F"))) + (run (at-most +17 hex-digit) "0123456789ABCDEF yolo")) + (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F"))) + (run (between +0 +16 hex-digit) "0123456789ABCDEF yolo")) + (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F"))) + (run (between +3 +16 hex-digit) "0123456789ABCDEF yolo")) + (should-fail (run (between +17 +100 hex-digit) "0123456789ABCDEF yolo")) + (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F"))) + (run (between +15 +20 hex-digit) "0123456789ABCDEF yolo")) + (match (#;Right (#;Some #"1")) (run (opt hex-digit) "123abc")) + (match (#;Right #;None) (run (opt hex-digit) "yolo")) + (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"a" #"b" #"c" #"d" #"e" #"f"))) + (run (sep-by space hex-digit) "0 1 2 3 4 5 6 7 8 9 a b c d e f YOLO")) + (match (#;Right "yolo") (run get-input "yolo")) + )) diff --git a/stdlib/test/test/lux/macro/ast.lux b/stdlib/test/test/lux/macro/ast.lux new file mode 100644 index 000000000..b06efce01 --- /dev/null +++ b/stdlib/test/test/lux/macro/ast.lux @@ -0,0 +1,31 @@ +(;module: + lux + (lux (codata [io]) + (control monad) + (data [text "Text/" Monoid<Text>] + [number]) + (macro ast) + (codata function)) + lux/test) + +(test: "lux/macro/ast exports" + (let% [<tests> (do-template [<expr> <text> <pattern>] + [(match <pattern> <expr>) + (match <text> (ast-to-text <expr>)) + (match true (:: Eq<AST> = <expr> <expr>))] + + [(bool true) "true" [["" -1 -1] (#;BoolS true)]] + [(bool false) "false" [_ (#;BoolS false)]] + [(int 123) "123" [_ (#;IntS 123)]] + [(real 123.0) "123.0" [_ (#;RealS 123.0)]] + [(char #"\n") "#\"\\n\"" [_ (#;CharS #"\n")]] + [(text "\n") "\"\\n\"" [_ (#;TextS "\n")]] + [(tag ["yolo" "lol"]) "#yolo;lol" [_ (#;TagS ["yolo" "lol"])]] + [(symbol ["yolo" "lol"]) "yolo;lol" [_ (#;SymbolS ["yolo" "lol"])]] + [(form (list (bool true) (int 123))) "(true 123)" (^ [_ (#;FormS (list [_ (#;BoolS true)] [_ (#;IntS 123)]))])] + [(tuple (list (bool true) (int 123))) "[true 123]" (^ [_ (#;TupleS (list [_ (#;BoolS true)] [_ (#;IntS 123)]))])] + [(record (list [(bool true) (int 123)])) "{true 123}" (^ [_ (#;RecordS (list [[_ (#;BoolS true)] [_ (#;IntS 123)]]))])] + [(local-tag "lol") "#lol" [_ (#;TagS ["" "lol"])]] + [(local-symbol "lol") "lol" [_ (#;SymbolS ["" "lol"])]] + )] + (test-all <tests>))) diff --git a/stdlib/test/test/lux/macro/syntax.lux b/stdlib/test/test/lux/macro/syntax.lux new file mode 100644 index 000000000..99f8550c0 --- /dev/null +++ b/stdlib/test/test/lux/macro/syntax.lux @@ -0,0 +1,176 @@ +(;module: + lux + (lux (codata [io]) + (control monad) + (data [text "Text/" Monoid<Text>] + [number]) + (macro [ast] + ["s" syntax #+ syntax: Syntax]) + (codata function)) + lux/test) + +(test: "lux/macro/syntax exports [Part 1]" + (let% [<simple-tests> (do-template [<pattern> <expr> <get> <ask> <demand>] + [(match (#;Right [_ <pattern>]) + (s;run (list <expr>) + <get>)) + (match (#;Right [_ true]) + (s;run (list <expr>) + (<ask> <pattern>))) + (match (#;Right [_ []]) + (s;run (list <expr>) + (<demand> <pattern>)))] + + [true (ast;bool true) s;bool s;bool? s;bool!] + [123 (ast;int 123) s;int s;int? s;int!] + [123.0 (ast;real 123.0) s;real s;real? s;real!] + [#"\n" (ast;char #"\n") s;char s;char? s;char!] + ["\n" (ast;text "\n") s;text s;text? s;text!] + [["yolo" "lol"] (ast;symbol ["yolo" "lol"]) s;symbol s;symbol? s;symbol!] + [["yolo" "lol"] (ast;tag ["yolo" "lol"]) s;tag s;tag? s;tag!] + ) + <group-tests> (do-template [<parser> <ctor>] + [(match (#;Right [_ [true 123]]) + (s;run (list (<ctor> (list (ast;bool true) (ast;int 123)))) + (<parser> (s;seq s;bool s;int)))) + (match (#;Right [_ true]) + (s;run (list (<ctor> (list (ast;bool true)))) + (<parser> s;bool))) + (match (#;Left _) + (s;run (list (<ctor> (list (ast;bool true) (ast;int 123)))) + (<parser> s;bool))) + (match (#;Right [_ (#;Left true)]) + (s;run (list (<ctor> (list (ast;bool true)))) + (<parser> (s;alt s;bool s;int)))) + (match (#;Right [_ (#;Right 123)]) + (s;run (list (<ctor> (list (ast;int 123)))) + (<parser> (s;alt s;bool s;int)))) + (match (#;Left _) + (s;run (list (<ctor> (list (ast;real 123.0)))) + (<parser> (s;alt s;bool s;int))))] + + [s;form ast;form] + [s;tuple ast;tuple])] + (test-all (match (#;Right [_ [_ (#;BoolS true)]]) + (s;run (list (ast;bool true) (ast;int 123)) + s;any)) + <simple-tests> + (match (#;Right [_ []]) + (s;run (list (ast;bool true) (ast;int 123)) + (s;assert true "yolo"))) + (match (#;Left _) + (s;run (list (ast;bool true) (ast;int 123)) + (s;assert false "yolo"))) + (match (#;Right [_ +123]) + (s;run (list (ast;nat +123)) + s;nat)) + (match (#;Left _) + (s;run (list (ast;int -123)) + s;nat)) + (match (#;Right [_ "yolo"]) + (s;run (list (ast;local-symbol "yolo")) + s;local-symbol)) + (match (#;Left _) + (s;run (list (ast;symbol ["yolo" "lol"])) + s;local-symbol)) + (match (#;Right [_ "yolo"]) + (s;run (list (ast;local-tag "yolo")) + s;local-tag)) + (match (#;Left _) + (s;run (list (ast;tag ["yolo" "lol"])) + s;local-tag)) + <group-tests> + ))) + +(test: "lux/macro/syntax exports [Part 2]" + (test-all (match (#;Right [_ [true 123]]) + (s;run (list (ast;record (list [(ast;bool true) (ast;int 123)]))) + (s;record (s;seq s;bool s;int)))) + (match (#;Right [_ (#;Some +123)]) + (s;run (list (ast;nat +123)) + (s;opt s;nat))) + (match (#;Right [_ #;None]) + (s;run (list (ast;int -123)) + (s;opt s;nat))) + (match (^ (#;Right [_ (list +123 +456 +789)])) + (s;run (list (ast;nat +123) (ast;nat +456) (ast;nat +789)) + (s;some s;nat))) + (match (^ (#;Right [_ (list)])) + (s;run (list (ast;int -123)) + (s;some s;nat))) + (match (^ (#;Right [_ (list +123 +456 +789)])) + (s;run (list (ast;nat +123) (ast;nat +456) (ast;nat +789)) + (s;many s;nat))) + (match (^ (#;Right [_ (list +123)])) + (s;run (list (ast;nat +123)) + (s;many s;nat))) + (match (#;Left _) + (s;run (list (ast;int -123)) + (s;many s;nat))) + (match (#;Right [_ 123]) + (s;run (list (ast;int 123) (ast;int 456) (ast;int 789)) + (s;either s;pos-int s;int))) + (match (#;Right [_ -123]) + (s;run (list (ast;int -123) (ast;int 456) (ast;int 789)) + (s;either s;pos-int s;int))) + (match (#;Left _) + (s;run (list (ast;bool true) (ast;int 456) (ast;int 789)) + (s;either s;pos-int s;int))) + (match (#;Right [_ true]) + (s;run (list) + s;end?)) + (match (#;Right [_ false]) + (s;run (list (ast;bool true)) + s;end?)) + (match (#;Right [_ []]) + (s;run (list) + s;end)) + (match (#;Left _) + (s;run (list (ast;bool true)) + s;end)) + (match (^ (#;Right [_ (list 123 456 789)])) + (s;run (list (ast;int 123) (ast;int 456) (ast;int 789)) + (s;exactly +3 s;int))) + (match (^ (#;Right [_ (list 123 456)])) + (s;run (list (ast;int 123) (ast;int 456) (ast;int 789)) + (s;exactly +2 s;int))) + (match (#;Left _) + (s;run (list (ast;int 123) (ast;int 456) (ast;int 789)) + (s;exactly +4 s;int))) + (match (^ (#;Right [_ (list 123 456 789)])) + (s;run (list (ast;int 123) (ast;int 456) (ast;int 789)) + (s;at-least +3 s;int))) + (match (^ (#;Right [_ (list 123 456 789)])) + (s;run (list (ast;int 123) (ast;int 456) (ast;int 789)) + (s;at-least +2 s;int))) + (match (#;Left _) + (s;run (list (ast;int 123) (ast;int 456) (ast;int 789)) + (s;at-least +4 s;int))) + (match (^ (#;Right [_ (list 123 456 789)])) + (s;run (list (ast;int 123) (ast;int 456) (ast;int 789)) + (s;at-most +3 s;int))) + (match (^ (#;Right [_ (list 123 456)])) + (s;run (list (ast;int 123) (ast;int 456) (ast;int 789)) + (s;at-most +2 s;int))) + (match (^ (#;Right [_ (list 123 456 789)])) + (s;run (list (ast;int 123) (ast;int 456) (ast;int 789)) + (s;at-most +4 s;int))) + (match (^ (#;Right [_ (list 123 456 789)])) + (s;run (list (ast;int 123) (ast;int 456) (ast;int 789)) + (s;between +3 +10 s;int))) + (match (#;Left _) + (s;run (list (ast;int 123) (ast;int 456) (ast;int 789)) + (s;between +4 +10 s;int))) + (match (^ (#;Right [_ (list 123 456 789)])) + (s;run (list (ast;int 123) (ast;text "YOLO") (ast;int 456) (ast;text "YOLO") (ast;int 789)) + (s;sep-by (s;text! "YOLO") s;int))) + (match (^ (#;Right [_ (list 123 456)])) + (s;run (list (ast;int 123) (ast;text "YOLO") (ast;int 456) (ast;int 789)) + (s;sep-by (s;text! "YOLO") s;int))) + (match (#;Left _) + (s;run (list (ast;int 123) (ast;int 456) (ast;int 789)) + (s;not s;int))) + (match (#;Right [_ []]) + (s;run (list (ast;bool true) (ast;int 456) (ast;int 789)) + (s;not s;int))) + )) diff --git a/stdlib/test/test/lux/math.lux b/stdlib/test/test/lux/math.lux new file mode 100644 index 000000000..3d5e053f7 --- /dev/null +++ b/stdlib/test/test/lux/math.lux @@ -0,0 +1,45 @@ +(;module: + lux + (lux (codata [io]) + (control monad) + (data [text "Text/" Monoid<Text>] + text/format + [number] + (struct [list "List/" Fold<List> Functor<List>]) + [product]) + (codata function) + math) + lux/test) + +(test: "lux/math exports" + (test-all (match 1.0 (cos 0.0)) + (match -1.0 (cos (/. 2.0 tau))) + ## (match 0.0 (cos (/. 4.0 tau))) + ## (match 0.0 (cos (*. (/. 4.0 3.0) tau))) + + (match 1.0 (sin (/. 4.0 tau))) + (match -1.0 (sin (*. (/. 4.0 3.0) tau))) + ## (match 0.0 (sin 0.0)) + ## (match 0.0 (sin (/. 2.0 tau))) + + (match 4 (ceil 3.75)) + (match 3 (floor 3.75)) + (match 4 (round 3.75)) + (match 3 (round 3.25)) + + (match 3.0 (cbrt 27.0)) + (match 4.0 (sqrt 16.0)) + + (match 90.0 (degrees (/. 4.0 tau))) + (match true (=. tau (radians (degrees tau)))) + + (match 9 (gcd 450 27)) + (match 40 (lcm 10 8)) + + (match 27 (infix 27)) + (match 9 (infix [27 gcd 450])) + (match 9 (infix [(* 3 9) gcd 450])) + (match true (infix [#and 27 < 450 < 2000])) + (match true (infix [#and 27 < 450 > 200])) + (match true (infix [[27 < 450] and [200 < 2000]])) + )) diff --git a/stdlib/test/test/lux/pipe.lux b/stdlib/test/test/lux/pipe.lux new file mode 100644 index 000000000..a601bbf98 --- /dev/null +++ b/stdlib/test/test/lux/pipe.lux @@ -0,0 +1,47 @@ +(;module: + lux + (lux (codata [io]) + (control monad) + (data text/format + [number] + [product] + identity) + (codata function) + pipe) + lux/test) + +(test: "lux/pipe exports" + (test-all (match 1 (|> 20 + (* 3) + (+ 4) + (_> 0 inc))) + (match 10 (|> 5 + (@> [(+ @ @)]))) + (match 15 (|> 5 + (?> [even?] [(* 2)] + [odd?] [(* 3)] + [(_> -1)]))) + (match 15 (|> 5 + (?> [even?] [(* 2)] + [odd?] [(* 3)]))) + (match 10 (|> 1 + (!> [(< 10)] + [inc]))) + (match 20 (|> 5 + (%> Monad<Identity> + [(* 3)] + [(+ 4)] + [inc]))) + (match "five" (|> 5 + (case> 0 "zero" + 1 "one" + 2 "two" + 3 "three" + 4 "four" + 5 "five" + 6 "six" + 7 "seven" + 8 "eight" + 9 "nine" + _ "???"))) + )) diff --git a/stdlib/test/test/lux/regex.lux b/stdlib/test/test/lux/regex.lux new file mode 100644 index 000000000..66355bdca --- /dev/null +++ b/stdlib/test/test/lux/regex.lux @@ -0,0 +1,200 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data error + [product]) + [compiler] + (macro [ast] + ["s" syntax #+ syntax:]) + test + [lexer] + regex)) + +(syntax: (should-regex {veredict (s;alt s;bool s;any)} {regex s;text} {input s;text}) + (case veredict + (+0 ?) + (if ? + (wrap (list (` (match+ (~ (ast;text input)) + (should-pass (lexer;run (regex (~ (ast;text regex))) + (~ (ast;text input)))))))) + (wrap (list (` (should-fail (lexer;run (regex (~ (ast;text regex))) + (~ (ast;text input)))))))) + + (+1 result) + (wrap (list (` (match+ (~ result) + (should-pass (lexer;run (regex (~ (ast;text regex))) + (~ (ast;text input)))))))))) + +## [Tests] +(test: "Regular Expressions [Basics]" + (test-all (should-regex true "a" "a") + (should-regex false "a" ".") + (should-regex true "\\." ".") + (should-regex false "\\." "a") + )) + +(test: "Regular Expressions [System character classes]" + (test-all (should-regex true "." "a") + + (should-regex true "\\d" "0") + (should-regex false "\\d" "m") + (should-regex true "\\D" "m") + (should-regex false "\\D" "0") + + (should-regex true "\\s" " ") + (should-regex false "\\s" "m") + (should-regex true "\\S" "m") + (should-regex false "\\S" " ") + + (should-regex true "\\w" "_") + (should-regex false "\\w" "^") + (should-regex true "\\W" ".") + (should-regex false "\\W" "a") + + (should-regex true "\\p{Lower}" "m") + (should-regex false "\\p{Lower}" "M") + + (should-regex true "\\p{Upper}" "M") + (should-regex false "\\p{Upper}" "m") + + (should-regex true "\\p{Alpha}" "M") + (should-regex false "\\p{Alpha}" "0") + + (should-regex true "\\p{Digit}" "1") + (should-regex false "\\p{Digit}" "n") + + (should-regex true "\\p{Alnum}" "1") + (should-regex false "\\p{Alnum}" ".") + + (should-regex true "\\p{Space}" " ") + (should-regex false "\\p{Space}" ".") + + (should-regex true "\\p{HexDigit}" "a") + (should-regex false "\\p{HexDigit}" ".") + + (should-regex true "\\p{OctDigit}" "6") + (should-regex false "\\p{OctDigit}" ".") + + (should-regex true "\\p{Blank}" "\t") + (should-regex false "\\p{Blank}" ".") + + (should-regex true "\\p{ASCII}" "\t") + (should-regex false "\\p{ASCII}" "\u1234") + + (should-regex true "\\p{Contrl}" "\u0012") + (should-regex false "\\p{Contrl}" "a") + + (should-regex true "\\p{Punct}" "@") + (should-regex false "\\p{Punct}" "a") + + (should-regex true "\\p{Graph}" "@") + (should-regex false "\\p{Graph}" " ") + + (should-regex true "\\p{Print}" "\u0020") + (should-regex false "\\p{Print}" "\u1234") + )) + +(test: "Regular Expressions [Custom character classes]" + (test-all (should-regex true "[abc]" "a") + (should-regex false "[abc]" "m") + + (should-regex true "[a-z]" "a") + (should-regex true "[a-z]" "m") + (should-regex true "[a-z]" "z") + + (should-regex true "[a-zA-Z]" "a") + (should-regex true "[a-zA-Z]" "m") + (should-regex true "[a-zA-Z]" "z") + (should-regex true "[a-zA-Z]" "A") + (should-regex true "[a-zA-Z]" "M") + (should-regex true "[a-zA-Z]" "Z") + + (should-regex false "[^abc]" "a") + (should-regex true "[^abc]" "m") + + (should-regex false "[^a-z]" "a") + (should-regex true "[^a-z]" "0") + (should-regex false "[^a-zA-Z]" "a") + (should-regex true "[^a-zA-Z]" "0") + + (should-regex false "[a-z&&[def]]" "a") + (should-regex true "[a-z&&[def]]" "d") + + (should-regex true "[a-z&&[^bc]]" "a") + (should-regex false "[a-z&&[^bc]]" "b") + + (should-regex true "[a-z&&[^m-p]]" "a") + (should-regex false "[a-z&&[^m-p]]" "m") + (should-regex false "[a-z&&[^m-p]]" "p") + )) + +(test: "Regular Expressions [Reference]" + (test-all (let [number (regex "\\d+")] + (should-regex ["809-345-6789" "809" "345" "6789"] "(\\@<number>)-(\\@<number>)-(\\@<number>)" "809-345-6789")) + )) + +(test: "Regular Expressions [Quantifiers]" + (test-all (should-regex "aa" "aa" "aa") + + (should-regex "a" "a?" "a") + (should-regex "" "a?" "") + + (should-regex "aaa" "a*" "aaa") + (should-regex "" "a*" "") + + (should-regex "aaa" "a+" "aaa") + (should-regex "a" "a+" "a") + (should-regex false "a+" "") + + (should-regex "aa" "a{2}" "aa") + (should-regex "a" "a{1}" "aa") + (should-regex false "a{3}" "aa") + + (should-regex "aa" "a{1,}" "aa") + (should-regex "aa" "a{2,}" "aa") + (should-regex false "a{3,}" "aa") + + (should-regex "a" "a{,1}" "aa") + (should-regex "aa" "a{,2}" "aa") + (should-regex "aa" "a{,3}" "aa") + + (should-regex "a" "a{1,2}" "a") + (should-regex "aa" "a{1,2}" "aa") + (should-regex "aa" "a{1,2}" "aaa") + )) + +(test: "Regular Expressions [Groups]" + (test-all (should-regex ["abc" "b"] "a(.)c" "abc") + (should-regex ["abbbbbc" "bbbbb"] "a(b+)c" "abbbbbc") + (should-regex ["809-345-6789" "809" "345" "6789"] "(\\d{3})-(\\d{3})-(\\d{4})" "809-345-6789") + (should-regex ["809-345-6789" "809" "6789"] "(\\d{3})-(?:\\d{3})-(\\d{4})" "809-345-6789") + (should-regex ["809-809-6789" "809" "6789"] "(\\d{3})-\\0-(\\d{4})" "809-809-6789") + (should-regex ["809-809-6789" "809" "6789"] "(?<code>\\d{3})-\\k<code>-(\\d{4})" "809-809-6789") + (should-regex ["809-809-6789-6789" "809" "6789"] "(?<code>\\d{3})-\\k<code>-(\\d{4})-\\0" "809-809-6789-6789") + + (should-regex ["809-345-6789" "809" ["345-6789" "345" "6789"]] "(\\d{3})-((\\d{3})-(\\d{4}))" "809-345-6789") + )) + +(test: "Regular Expressions [Alternation]" + (test-all (should-regex ["a" (+0 [])] "a|b" "a") + (should-regex ["b" (+1 [])] "a|b" "b") + (should-regex false "a|b" "c") + + (should-regex ["abc" (+0 "b")] "a(.)c|b(.)d" "abc") + (should-regex ["bcd" (+1 "c")] "a(.)c|b(.)d" "bcd") + (should-regex false "a(.)c|b(.)d" "cde") + + (should-regex ["abc" (+0 ["b" "c"])] "a(.)(.)|b(.)(.)" "abc") + (should-regex ["bcd" (+1 ["c" "d"])] "a(.)(.)|b(.)(.)" "bcd") + (should-regex false "a(.)(.)|b(.)(.)" "cde") + + (should-regex ["809-345-6789" (+0 ["809" "345-6789" "345" "6789"])] + "(\\d{3})-((\\d{3})-(\\d{4}))|b(.)d" + "809-345-6789") + )) diff --git a/stdlib/test/test/lux/type.lux b/stdlib/test/test/lux/type.lux new file mode 100644 index 000000000..8fa871e70 --- /dev/null +++ b/stdlib/test/test/lux/type.lux @@ -0,0 +1,41 @@ +(;module: + lux + (lux (codata [io]) + (control monad) + (data [text "Text/" Monoid<Text>] + [number]) + type + (codata function)) + lux/test) + +(test: "lux/type exports" + (let% [<eq-tests> (do-template [<type>] + [(match true (:: Eq<Type> = <type> <type>))] + + [(#;HostT "java.util.List" (list Int))] + [#;UnitT] + [#;VoidT] + [(#;VarT +123)] + [(#;ExT +123)] + [(#;BoundT +123)] + [(#;LambdaT Bool Int)] + [(#;AppT List Int)] + [(#;NamedT ["" "Int-List"] (#;AppT List Int))] + [(#;SumT Bool Int)] + [(#;ProdT Bool Int)] + [(#;UnivQ (list) (#;ProdT Bool (#;BoundT +1)))] + [(#;ExQ (list) (#;ProdT Bool (#;BoundT +1)))] + )] + (test-all <eq-tests> + (match (^=> (#;Some _type) (:: Eq<Type> = _type (#;ProdT Bool Int))) + (apply-type (type (Meta Bool)) Int)) + (match #;None (apply-type Text Bool)) + (match true + (:: Eq<Type> = + (#;NamedT ["" "a"] + (#;ProdT Bool Int)) + (un-alias (#;NamedT ["" "c"] + (#;NamedT ["" "b"] + (#;NamedT ["" "a"] + (#;ProdT Bool Int))))))) + ))) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux new file mode 100644 index 000000000..7b760c0f1 --- /dev/null +++ b/stdlib/test/tests.lux @@ -0,0 +1,84 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monad) + (codata [io]) + (concurrency [promise]) + [cli #+ program:] + [test]) + (test lux + (lux (data [bit] + [bool] + [char] + [error] + [ident] + [identity] + [log] + [maybe] + [number] + [product] + [sum] + [text] + [text/format] + (struct [array] + [dict] + [list] + [queue] + [set] + [stack] + [tree] + [vector] + [zipper] + ) + ) + ## (codata ["_;" io] + ## [env] + ## [state] + ## (struct [stream])) + ## (macro [ast] + ## [syntax]) + ## [type] + ## (concurrency ["_;" promise] + ## [frp] + ## [stm] + ## [actor] + ## ) + ## [host] + ## ["_;" cli] + ## [math] + ## [pipe] + ## [lexer] + ## [regex] + ## (data (format [json])) + ) + ) + ## (lux ## (codata [cont]) + ## ## (data (struct [stack] + ## ## [tree] + ## ## [zipper]) + ## ## (error exception)) + ## ## (concurrency [atom]) + ## ## [macro] + ## ## (macro [template] + ## ## [poly] + ## ## (poly ["poly_;" eq] + ## ## ["poly_;" text-encoder] + ## ## ["poly_;" functor])) + ## ## (math [ratio] + ## ## [complex] + ## ## [random]) + ## ## (type [check] [auto]) + ## ## (control [effect]) + ## ["_;" lexer] + ## ["_;" regex] + ## (data (format ["_;" json])) + ## ) + ) + +## [Program] +(program: args + (test;run)) |