diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for zeolite + +## 0.1.0.0 -- 2020-04-27 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,177 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/base/.zeolite-module b/base/.zeolite-module new file mode 100644 --- /dev/null +++ b/base/.zeolite-module @@ -0,0 +1,1 @@ +RecompileMetadata {rmRoot = "..", rmPath = "base", rmPublicDeps = [], rmPrivateDeps = [], rmExtraFiles = ["base/builtin.cpp","base/builtin.hpp","base/category-header.hpp","base/category-source.cpp","base/argv.cpp","base/builtin.cpp","base/category-source.hpp","base/cycle-check.hpp","base/function.hpp","base/logging.cpp","base/logging.hpp","base/types.cpp","base/types.hpp","capture-thread/include/thread-capture.h","capture-thread/include/thread-crosser.h","capture-thread/src/thread-crosser.cc"], rmExtraPaths = ["base","capture-thread/include"], rmExtraRequires = ["Bool","Char","Int","Float","String","AsBool","AsChar","AsInt","AsFloat","AsString","Formatted","Equals","LessThan","ReadPosition"], rmMode = CompileIncremental, rmOutputName = ""} diff --git a/base/argv.cpp b/base/argv.cpp new file mode 100644 --- /dev/null +++ b/base/argv.cpp @@ -0,0 +1,42 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#include "argv.hpp" +#include "logging.hpp" + + +int Argv::ArgCount() { + if (GetCurrent()) { + return GetCurrent()->GetArgs().size(); + } else { + return 0; + } +} + +const std::string& Argv::GetArgAt(int pos) { + if (pos < 0 || pos >= ArgCount()) { + FAIL() << "Argv index " << pos << " is out of bounds"; + __builtin_unreachable(); + } else { + return GetCurrent()->GetArgs()[pos]; + } +} + +const std::vector& ProgramArgv::GetArgs() const { + return argv_; +} diff --git a/base/argv.hpp b/base/argv.hpp new file mode 100644 --- /dev/null +++ b/base/argv.hpp @@ -0,0 +1,52 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#ifndef ARGV_HPP_ +#define ARGV_HPP_ + +#include +#include + +#include "thread-capture.h" + + +class Argv : public capture_thread::ThreadCapture { + public: + static int ArgCount(); + static const std::string& GetArgAt(int pos); + + protected: + virtual ~Argv() = default; + + private: + virtual const std::vector& GetArgs() const = 0; +}; + +class ProgramArgv : public Argv { + public: + inline ProgramArgv(int argc, const char** argv) + : argv_(argv, argv + argc), capture_to_(this) {} + + private: + const std::vector& GetArgs() const final; + + const std::vector argv_; + const ScopedCapture capture_to_; +}; + +#endif // ARGV_HPP_ diff --git a/base/builtin.0rp b/base/builtin.0rp new file mode 100644 --- /dev/null +++ b/base/builtin.0rp @@ -0,0 +1,103 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +concrete Bool { + refines AsBool + refines AsInt + refines AsFloat + refines Formatted + + defines Equals +} + +concrete Char { + refines AsBool + refines AsChar + refines AsInt + refines AsFloat + refines Formatted + + defines Equals + defines LessThan +} + +concrete Int { + refines AsBool + refines AsChar + refines AsInt + refines AsFloat + refines Formatted + + defines Equals + defines LessThan +} + +concrete Float { + refines AsBool + refines AsInt + refines AsFloat + refines Formatted + + defines Equals + defines LessThan +} + +concrete String { + refines AsBool + refines Formatted + refines ReadPosition + + defines Equals + defines LessThan + + @value subSequence (Int,Int) -> (String) +} + +@value interface AsBool { + asBool () -> (Bool) +} + +@value interface AsInt { + asInt () -> (Int) +} + +@value interface AsChar { + asChar () -> (Char) +} + +@value interface AsFloat { + asFloat () -> (Float) +} + +@type interface LessThan<#x|> { + lessThan (#x,#x) -> (Bool) +} + +@type interface Equals<#x|> { + equals (#x,#x) -> (Bool) +} + +@value interface Formatted { + formatted () -> (String) +} + +@value interface ReadPosition<|#x> { + readPosition (Int) -> (#x) + readSize () -> (Int) + subSequence (Int,Int) -> (ReadPosition<#x>) +} diff --git a/base/builtin.cpp b/base/builtin.cpp new file mode 100644 --- /dev/null +++ b/base/builtin.cpp @@ -0,0 +1,1192 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#include "builtin.hpp" + +#include +#include + +#include "category-source.hpp" +#include "Category_AsBool.hpp" +#include "Category_AsChar.hpp" +#include "Category_AsInt.hpp" +#include "Category_AsFloat.hpp" +#include "Category_Bool.hpp" +#include "Category_Char.hpp" +#include "Category_Equals.hpp" +#include "Category_Float.hpp" +#include "Category_Formatted.hpp" +#include "Category_Int.hpp" +#include "Category_LessThan.hpp" +#include "Category_ReadPosition.hpp" +#include "Category_String.hpp" + + +void BuiltinFail(const S& formatted) { + FAIL() << TypeValue::Call(formatted, Function_Formatted_formatted, + ParamTuple(), ArgTuple()).Only()->AsString(); + __builtin_unreachable(); +} + +namespace { + +struct OptionalEmpty : public TypeValue { + ReturnTuple Dispatch(const S& self, + const ValueFunction& label, + const ParamTuple& params, const ValueTuple& args) final { + FAIL() << "Function called on empty value"; + __builtin_unreachable(); + } + + std::string CategoryName() const final { return "empty"; } + + bool Present() const final { return false; } +}; + +struct Type_Intersect : public TypeInstance { + Type_Intersect(L params) : params_(params.begin(), params.end()) {} + + std::string CategoryName() const final { return "(intersection)"; } + + void BuildTypeName(std::ostream& output) const final { + if (params_.empty()) { + output << "any"; + } else { + output << "["; + bool first = true; + for (const auto param : params_) { + if (!first) output << "&"; + first = false; + param->BuildTypeName(output); + } + output << "]"; + } + } + + MergeType InstanceMergeType() const final + { return MergeType::INTERSECT; } + + std::vector MergedTypes() const final + { return params_; } + + const L params_; +}; + +struct Type_Union : public TypeInstance { + Type_Union(L params) : params_(params.begin(), params.end()) {} + + std::string CategoryName() const final { return "(union)"; } + + void BuildTypeName(std::ostream& output) const final { + if (params_.empty()) { + output << "all"; + } else { + output << "["; + bool first = true; + for (const auto param : params_) { + if (!first) output << "|"; + first = false; + param->BuildTypeName(output); + } + output << "]"; + } + } + + MergeType InstanceMergeType() const final + { return MergeType::UNION; } + + std::vector MergedTypes() const final + { return params_; } + + const L params_; +}; + +} // namespace + + +TypeInstance& Merge_Intersect(L params) { + static auto& cache = *new std::map,R>(); + auto& cached = cache[params]; + if (!cached) { cached = R_get(new Type_Intersect(params)); } + return *cached; +} + +TypeInstance& Merge_Union(L params) { + static auto& cache = *new std::map,R>(); + auto& cached = cache[params]; + if (!cached) { cached = R_get(new Type_Union(params)); } + return *cached; +} + +TypeInstance& GetMerged_Any() { + static auto& instance = Merge_Intersect(L_get()); + return instance; +} + +TypeInstance& GetMerged_All() { + static auto& instance = Merge_Union(L_get()); + return instance; +} + + +const S& Var_empty = *new S(new OptionalEmpty()); + + +// Bool + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +namespace ZEOLITE_DYNAMIC_NAMESPACE { +#endif // ZEOLITE_DYNAMIC_NAMESPACE +namespace { +const int collection_Bool = 0; +} // namespace +const void* const Functions_Bool = &collection_Bool; +namespace { +class Category_Bool; +class Type_Bool; +Type_Bool& CreateType_Bool(Params<0>::Type params); +class Value_Bool; +S CreateValue(Type_Bool& parent, const ParamTuple& params, const ValueTuple& args); +struct Category_Bool : public TypeCategory { + std::string CategoryName() const final { return "Bool"; } + Category_Bool() { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("Bool (init @category)") + } + ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Category_Bool::*)(const ParamTuple&, const ValueTuple&); + return TypeCategory::Dispatch(label, params, args); + } +}; +Category_Bool& CreateCategory_Bool() { + static auto& category = *new Category_Bool(); + return category; +} +struct Type_Bool : public TypeInstance { + std::string CategoryName() const final { return parent.CategoryName(); } + void BuildTypeName(std::ostream& output) const final { + return TypeInstance::TypeNameFrom(output, parent); + } + Category_Bool& parent; + bool CanConvertFrom(const TypeInstance& from) const final { + std::vector args; + if (!from.TypeArgsForParent(parent, args)) return false; + if(args.size() != 0) { + FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); + } + return true; + } + bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + if (&category == &GetCategory_Bool()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_AsBool()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_AsInt()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_AsFloat()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_Formatted()) { + args = std::vector{}; + return true; + } + return false; + } + Type_Bool(Category_Bool& p, Params<0>::Type params) : parent(p) { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("Bool (init @type)") + } + ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Type_Bool::*)(const ParamTuple&, const ValueTuple&); + static const CallType Table_Equals[] = { + &Type_Bool::Call_equals, + }; + if (label.collection == Functions_Equals) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_Equals[label.function_num])(params, args); + } + return TypeInstance::Dispatch(label, params, args); + } + ReturnTuple Call_equals(const ParamTuple& params, const ValueTuple& args); +}; +Type_Bool& CreateType_Bool(Params<0>::Type params) { + static auto& cache = *new InstanceMap<0,Type_Bool>(); + auto& cached = cache[params]; + if (!cached) { cached = R_get(new Type_Bool(CreateCategory_Bool(), params)); } + return *cached; +} +struct Value_Bool : public TypeValue { + Value_Bool(Type_Bool& p, bool value) : parent(p), value_(value) {} + ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { + using CallType = ReturnTuple(Value_Bool::*)(const S&, const ParamTuple&, const ValueTuple&); + static const CallType Table_AsBool[] = { + &Value_Bool::Call_asBool, + }; + static const CallType Table_AsFloat[] = { + &Value_Bool::Call_asFloat, + }; + static const CallType Table_AsInt[] = { + &Value_Bool::Call_asInt, + }; + static const CallType Table_Formatted[] = { + &Value_Bool::Call_formatted, + }; + if (label.collection == Functions_AsBool) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_AsBool[label.function_num])(self, params, args); + } + if (label.collection == Functions_AsFloat) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_AsFloat[label.function_num])(self, params, args); + } + if (label.collection == Functions_AsInt) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_AsInt[label.function_num])(self, params, args); + } + if (label.collection == Functions_Formatted) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_Formatted[label.function_num])(self, params, args); + } + return TypeValue::Dispatch(self, label, params, args); + } + std::string CategoryName() const final { return parent.CategoryName(); } + bool AsBool() const final { return value_; } + ReturnTuple Call_asBool(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_asFloat(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_asInt(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_formatted(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + Type_Bool& parent; + const bool value_; +}; +ReturnTuple Type_Bool::Call_equals(const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Bool.equals") + const bool Var_arg1 = (args.At(0))->AsBool(); + const bool Var_arg2 = (args.At(1))->AsBool(); + return ReturnTuple(Box_Bool(Var_arg1==Var_arg2)); +} +ReturnTuple Value_Bool::Call_asBool(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Bool.asBool") + return ReturnTuple(Var_self); +} +ReturnTuple Value_Bool::Call_asFloat(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Bool.asFloat") + return ReturnTuple(Box_Float(value_ ? 1.0 : 0.0)); +} +ReturnTuple Value_Bool::Call_asInt(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Bool.asInt") + return ReturnTuple(Box_Int(value_? 1 : 0)); +} +ReturnTuple Value_Bool::Call_formatted(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Bool.formatted") + return ReturnTuple(Box_String(value_? "true" : "false")); +} +const S& Var_true = *new S(new Value_Bool(CreateType_Bool(Params<0>::Type()), true)); +const S& Var_false = *new S(new Value_Bool(CreateType_Bool(Params<0>::Type()), false)); +} // namespace +TypeCategory& GetCategory_Bool() { + return CreateCategory_Bool(); +} +TypeInstance& GetType_Bool(Params<0>::Type params) { + return CreateType_Bool(params); +} +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +} // namespace ZEOLITE_DYNAMIC_NAMESPACE +using namespace ZEOLITE_DYNAMIC_NAMESPACE; +#endif // ZEOLITE_DYNAMIC_NAMESPACE + + +// Char + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +namespace ZEOLITE_DYNAMIC_NAMESPACE { +#endif // ZEOLITE_DYNAMIC_NAMESPACE +namespace { +const int collection_Char = 0; +} // namespace +const void* const Functions_Char = &collection_Char; +namespace { +class Category_Char; +class Type_Char; +Type_Char& CreateType_Char(Params<0>::Type params); +class Value_Char; +S CreateValue(Type_Char& parent, const ParamTuple& params, const ValueTuple& args); +struct Category_Char : public TypeCategory { + std::string CategoryName() const final { return "Char"; } + Category_Char() { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("Char (init @category)") + } + ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Category_Char::*)(const ParamTuple&, const ValueTuple&); + return TypeCategory::Dispatch(label, params, args); + } +}; +Category_Char& CreateCategory_Char() { + static auto& category = *new Category_Char(); + return category; +} +struct Type_Char : public TypeInstance { + std::string CategoryName() const final { return parent.CategoryName(); } + void BuildTypeName(std::ostream& output) const final { + return TypeInstance::TypeNameFrom(output, parent); + } + Category_Char& parent; + bool CanConvertFrom(const TypeInstance& from) const final { + std::vector args; + if (!from.TypeArgsForParent(parent, args)) return false; + if(args.size() != 0) { + FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); + } + return true; + } + bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + if (&category == &GetCategory_Char()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_AsBool()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_AsChar()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_AsInt()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_AsFloat()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_Formatted()) { + args = std::vector{}; + return true; + } + return false; + } + Type_Char(Category_Char& p, Params<0>::Type params) : parent(p) { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("Char (init @type)") + } + ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Type_Char::*)(const ParamTuple&, const ValueTuple&); + static const CallType Table_Equals[] = { + &Type_Char::Call_equals, + }; + static const CallType Table_LessThan[] = { + &Type_Char::Call_lessThan, + }; + if (label.collection == Functions_Equals) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_Equals[label.function_num])(params, args); + } + if (label.collection == Functions_LessThan) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_LessThan[label.function_num])(params, args); + } + return TypeInstance::Dispatch(label, params, args); + } + ReturnTuple Call_equals(const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_lessThan(const ParamTuple& params, const ValueTuple& args); +}; +Type_Char& CreateType_Char(Params<0>::Type params) { + static auto& cache = *new InstanceMap<0,Type_Char>(); + auto& cached = cache[params]; + if (!cached) { cached = R_get(new Type_Char(CreateCategory_Char(), params)); } + return *cached; +} +struct Value_Char : public TypeValue { + Value_Char(Type_Char& p, PrimChar value) : parent(p), value_(value) {} + ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { + using CallType = ReturnTuple(Value_Char::*)(const S&, const ParamTuple&, const ValueTuple&); + static const CallType Table_AsBool[] = { + &Value_Char::Call_asBool, + }; + static const CallType Table_AsChar[] = { + &Value_Char::Call_asChar, + }; + static const CallType Table_AsFloat[] = { + &Value_Char::Call_asFloat, + }; + static const CallType Table_AsInt[] = { + &Value_Char::Call_asInt, + }; + static const CallType Table_Formatted[] = { + &Value_Char::Call_formatted, + }; + if (label.collection == Functions_AsBool) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_AsBool[label.function_num])(self, params, args); + } + if (label.collection == Functions_AsChar) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_AsChar[label.function_num])(self, params, args); + } + if (label.collection == Functions_AsFloat) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_AsFloat[label.function_num])(self, params, args); + } + if (label.collection == Functions_AsInt) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_AsInt[label.function_num])(self, params, args); + } + if (label.collection == Functions_Formatted) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_Formatted[label.function_num])(self, params, args); + } + return TypeValue::Dispatch(self, label, params, args); + } + std::string CategoryName() const final { return parent.CategoryName(); } + PrimChar AsChar() const final { return value_; } + ReturnTuple Call_asBool(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_asChar(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_asFloat(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_asInt(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_formatted(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + Type_Char& parent; + const PrimChar value_; +}; +ReturnTuple Type_Char::Call_equals(const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Char.equals") + const PrimChar Var_arg1 = (args.At(0))->AsChar(); + const PrimChar Var_arg2 = (args.At(1))->AsChar(); + return ReturnTuple(Box_Bool(Var_arg1==Var_arg2)); +} +ReturnTuple Type_Char::Call_lessThan(const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Char.lessThan") + const PrimChar Var_arg1 = (args.At(0))->AsChar(); + const PrimChar Var_arg2 = (args.At(1))->AsChar(); + return ReturnTuple(Box_Bool(Var_arg1& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Char.asBool") + return ReturnTuple(Box_Bool(value_ != '\0')); +} +ReturnTuple Value_Char::Call_asChar(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Char.asChar") + return ReturnTuple(Var_self); +} +ReturnTuple Value_Char::Call_asFloat(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Char.asFloat") + return ReturnTuple(Box_Float(value_)); +} +ReturnTuple Value_Char::Call_asInt(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Char.asInt") + return ReturnTuple(Box_Int(value_)); +} +ReturnTuple Value_Char::Call_formatted(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Char.formatted") + std::ostringstream output; + output << value_; + return ReturnTuple(Box_String(output.str())); +} +} // namespace +TypeCategory& GetCategory_Char() { + return CreateCategory_Char(); +} +TypeInstance& GetType_Char(Params<0>::Type params) { + return CreateType_Char(params); +} +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +} // namespace ZEOLITE_DYNAMIC_NAMESPACE +using namespace ZEOLITE_DYNAMIC_NAMESPACE; +#endif // ZEOLITE_DYNAMIC_NAMESPACE + + +// Int + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +namespace ZEOLITE_DYNAMIC_NAMESPACE { +#endif // ZEOLITE_DYNAMIC_NAMESPACE +namespace { +const int collection_Int = 0; +} // namespace +const void* const Functions_Int = &collection_Int; +namespace { +class Category_Int; +class Type_Int; +Type_Int& CreateType_Int(Params<0>::Type params); +class Value_Int; +S CreateValue(Type_Int& parent, const ParamTuple& params, const ValueTuple& args); +struct Category_Int : public TypeCategory { + std::string CategoryName() const final { return "Int"; } + Category_Int() { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("Int (init @category)") + } + ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Category_Int::*)(const ParamTuple&, const ValueTuple&); + return TypeCategory::Dispatch(label, params, args); + } +}; +Category_Int& CreateCategory_Int() { + static auto& category = *new Category_Int(); + return category; +} +struct Type_Int : public TypeInstance { + std::string CategoryName() const final { return parent.CategoryName(); } + void BuildTypeName(std::ostream& output) const final { + return TypeInstance::TypeNameFrom(output, parent); + } + Category_Int& parent; + bool CanConvertFrom(const TypeInstance& from) const final { + std::vector args; + if (!from.TypeArgsForParent(parent, args)) return false; + if(args.size() != 0) { + FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); + } + return true; + } + bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + if (&category == &GetCategory_Int()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_AsBool()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_AsChar()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_AsInt()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_AsFloat()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_Formatted()) { + args = std::vector{}; + return true; + } + return false; + } + Type_Int(Category_Int& p, Params<0>::Type params) : parent(p) { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("Int (init @type)") + } + ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Type_Int::*)(const ParamTuple&, const ValueTuple&); + static const CallType Table_Equals[] = { + &Type_Int::Call_equals, + }; + static const CallType Table_LessThan[] = { + &Type_Int::Call_lessThan, + }; + if (label.collection == Functions_Equals) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_Equals[label.function_num])(params, args); + } + if (label.collection == Functions_LessThan) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_LessThan[label.function_num])(params, args); + } + return TypeInstance::Dispatch(label, params, args); + } + ReturnTuple Call_equals(const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_lessThan(const ParamTuple& params, const ValueTuple& args); +}; +Type_Int& CreateType_Int(Params<0>::Type params) { + static auto& cache = *new InstanceMap<0,Type_Int>(); + auto& cached = cache[params]; + if (!cached) { cached = R_get(new Type_Int(CreateCategory_Int(), params)); } + return *cached; +} +struct Value_Int : public TypeValue { + Value_Int(Type_Int& p, PrimInt value) : parent(p), value_(value) {} + ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { + using CallType = ReturnTuple(Value_Int::*)(const S&, const ParamTuple&, const ValueTuple&); + static const CallType Table_AsBool[] = { + &Value_Int::Call_asBool, + }; + static const CallType Table_AsChar[] = { + &Value_Int::Call_asChar, + }; + static const CallType Table_AsFloat[] = { + &Value_Int::Call_asFloat, + }; + static const CallType Table_AsInt[] = { + &Value_Int::Call_asInt, + }; + static const CallType Table_Formatted[] = { + &Value_Int::Call_formatted, + }; + if (label.collection == Functions_AsBool) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_AsBool[label.function_num])(self, params, args); + } + if (label.collection == Functions_AsChar) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_AsChar[label.function_num])(self, params, args); + } + if (label.collection == Functions_AsFloat) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_AsFloat[label.function_num])(self, params, args); + } + if (label.collection == Functions_AsInt) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_AsInt[label.function_num])(self, params, args); + } + if (label.collection == Functions_Formatted) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_Formatted[label.function_num])(self, params, args); + } + return TypeValue::Dispatch(self, label, params, args); + } + std::string CategoryName() const final { return parent.CategoryName(); } + PrimInt AsInt() const final { return value_; } + ReturnTuple Call_asBool(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_asChar(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_asFloat(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_asInt(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_formatted(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + Type_Int& parent; + const PrimInt value_; +}; +ReturnTuple Type_Int::Call_equals(const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Int.equals") + const PrimInt Var_arg1 = (args.At(0))->AsInt(); + const PrimInt Var_arg2 = (args.At(1))->AsInt(); + return ReturnTuple(Box_Bool(Var_arg1==Var_arg2)); +} +ReturnTuple Type_Int::Call_lessThan(const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Int.lessThan") + const PrimInt Var_arg1 = (args.At(0))->AsInt(); + const PrimInt Var_arg2 = (args.At(1))->AsInt(); + return ReturnTuple(Box_Bool(Var_arg1& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Int.asBool") + return ReturnTuple(Box_Bool(value_ != 0)); +} +ReturnTuple Value_Int::Call_asChar(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Int.asChar") + return ReturnTuple(Box_Char(value_ % 0xff)); +} +ReturnTuple Value_Int::Call_asFloat(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Int.asFloat") + return ReturnTuple(Box_Float(value_)); +} +ReturnTuple Value_Int::Call_asInt(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Int.asInt") + return ReturnTuple(Var_self); +} +ReturnTuple Value_Int::Call_formatted(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Int.formatted") + std::ostringstream output; + output << value_; + return ReturnTuple(Box_String(output.str())); +} +} // namespace +TypeCategory& GetCategory_Int() { + return CreateCategory_Int(); +} +TypeInstance& GetType_Int(Params<0>::Type params) { + return CreateType_Int(params); +} +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +} // namespace ZEOLITE_DYNAMIC_NAMESPACE +using namespace ZEOLITE_DYNAMIC_NAMESPACE; +#endif // ZEOLITE_DYNAMIC_NAMESPACE + + +// Float + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +namespace ZEOLITE_DYNAMIC_NAMESPACE { +#endif // ZEOLITE_DYNAMIC_NAMESPACE +namespace { +const int collection_Float = 0; +} // namespace +const void* const Functions_Float = &collection_Float; +namespace { +class Category_Float; +class Type_Float; +Type_Float& CreateType_Float(Params<0>::Type params); +class Value_Float; +S CreateValue(Type_Float& parent, const ParamTuple& params, const ValueTuple& args); +struct Category_Float : public TypeCategory { + std::string CategoryName() const final { return "Float"; } + Category_Float() { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("Float (init @category)") + } + ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Category_Float::*)(const ParamTuple&, const ValueTuple&); + return TypeCategory::Dispatch(label, params, args); + } +}; +Category_Float& CreateCategory_Float() { + static auto& category = *new Category_Float(); + return category; +} +struct Type_Float : public TypeInstance { + std::string CategoryName() const final { return parent.CategoryName(); } + void BuildTypeName(std::ostream& output) const final { + return TypeInstance::TypeNameFrom(output, parent); + } + Category_Float& parent; + bool CanConvertFrom(const TypeInstance& from) const final { + std::vector args; + if (!from.TypeArgsForParent(parent, args)) return false; + if(args.size() != 0) { + FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); + } + return true; + } + bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + if (&category == &GetCategory_Float()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_AsBool()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_AsInt()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_AsFloat()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_Formatted()) { + args = std::vector{}; + return true; + } + return false; + } + Type_Float(Category_Float& p, Params<0>::Type params) : parent(p) { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("Float (init @type)") + } + ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Type_Float::*)(const ParamTuple&, const ValueTuple&); + static const CallType Table_Equals[] = { + &Type_Float::Call_equals, + }; + static const CallType Table_LessThan[] = { + &Type_Float::Call_lessThan, + }; + if (label.collection == Functions_Equals) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_Equals[label.function_num])(params, args); + } + if (label.collection == Functions_LessThan) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_LessThan[label.function_num])(params, args); + } + return TypeInstance::Dispatch(label, params, args); + } + ReturnTuple Call_equals(const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_lessThan(const ParamTuple& params, const ValueTuple& args); +}; +Type_Float& CreateType_Float(Params<0>::Type params) { + static auto& cache = *new InstanceMap<0,Type_Float>(); + auto& cached = cache[params]; + if (!cached) { cached = R_get(new Type_Float(CreateCategory_Float(), params)); } + return *cached; +} +struct Value_Float : public TypeValue { + Value_Float(Type_Float& p, PrimFloat value) : parent(p), value_(value) {} + ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { + using CallType = ReturnTuple(Value_Float::*)(const S&, const ParamTuple&, const ValueTuple&); + static const CallType Table_AsBool[] = { + &Value_Float::Call_asBool, + }; + static const CallType Table_AsFloat[] = { + &Value_Float::Call_asFloat, + }; + static const CallType Table_AsInt[] = { + &Value_Float::Call_asInt, + }; + static const CallType Table_Formatted[] = { + &Value_Float::Call_formatted, + }; + if (label.collection == Functions_AsBool) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_AsBool[label.function_num])(self, params, args); + } + if (label.collection == Functions_AsFloat) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_AsFloat[label.function_num])(self, params, args); + } + if (label.collection == Functions_AsInt) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_AsInt[label.function_num])(self, params, args); + } + if (label.collection == Functions_Formatted) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_Formatted[label.function_num])(self, params, args); + } + return TypeValue::Dispatch(self, label, params, args); + } + std::string CategoryName() const final { return parent.CategoryName(); } + PrimFloat AsFloat() const final { return value_; } + ReturnTuple Call_asBool(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_asFloat(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_asInt(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_formatted(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + Type_Float& parent; + const PrimFloat value_; +}; +ReturnTuple Type_Float::Call_equals(const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Float.equals") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + const PrimFloat Var_arg2 = (args.At(1))->AsFloat(); + return ReturnTuple(Box_Bool(Var_arg1==Var_arg2)); +} +ReturnTuple Type_Float::Call_lessThan(const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Float.lessThan") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + const PrimFloat Var_arg2 = (args.At(1))->AsFloat(); + return ReturnTuple(Box_Bool(Var_arg1& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Float.asBool") + return ReturnTuple(Box_Bool(value_ != 0.0)); +} +ReturnTuple Value_Float::Call_asFloat(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Float.asFloat") + return ReturnTuple(Var_self); +} +ReturnTuple Value_Float::Call_asInt(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Float.asInt") + return ReturnTuple(Box_Int(value_)); +} +ReturnTuple Value_Float::Call_formatted(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Float.formatted") + std::ostringstream output; + output << value_; + return ReturnTuple(Box_String(output.str())); +} +} // namespace +TypeCategory& GetCategory_Float() { + return CreateCategory_Float(); +} +TypeInstance& GetType_Float(Params<0>::Type params) { + return CreateType_Float(params); +} +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +} // namespace ZEOLITE_DYNAMIC_NAMESPACE +using namespace ZEOLITE_DYNAMIC_NAMESPACE; +#endif // ZEOLITE_DYNAMIC_NAMESPACE + + +// String + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +namespace ZEOLITE_DYNAMIC_NAMESPACE { +#endif // ZEOLITE_DYNAMIC_NAMESPACE +namespace { +const int collection_String = 0; +} // namespace +const void* const Functions_String = &collection_String; +const ValueFunction& Function_String_subSequence = (*new ValueFunction{ 0, 2, 1, "String", "subSequence", Functions_String, 0 }); +namespace { +class Category_String; +class Type_String; +Type_String& CreateType_String(Params<0>::Type params); +class Value_String; +S CreateValue(Type_String& parent, const ParamTuple& params, const ValueTuple& args); +struct Category_String : public TypeCategory { + std::string CategoryName() const final { return "String"; } + Category_String() { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("String (init @category)") + } + ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Category_String::*)(const ParamTuple&, const ValueTuple&); + return TypeCategory::Dispatch(label, params, args); + } +}; +Category_String& CreateCategory_String() { + static auto& category = *new Category_String(); + return category; +} +struct Type_String : public TypeInstance { + std::string CategoryName() const final { return parent.CategoryName(); } + void BuildTypeName(std::ostream& output) const final { + return TypeInstance::TypeNameFrom(output, parent); + } + Category_String& parent; + bool CanConvertFrom(const TypeInstance& from) const final { + std::vector args; + if (!from.TypeArgsForParent(parent, args)) return false; + if(args.size() != 0) { + FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); + } + return true; + } + bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + if (&category == &GetCategory_String()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_AsBool()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_Formatted()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_ReadPosition()) { + args = std::vector{&GetType_Char(T_get())}; + return true; + } + return false; + } + Type_String(Category_String& p, Params<0>::Type params) : parent(p) { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("String (init @type)") + } + ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Type_String::*)(const ParamTuple&, const ValueTuple&); + static const CallType Table_Equals[] = { + &Type_String::Call_equals, + }; + static const CallType Table_LessThan[] = { + &Type_String::Call_lessThan, + }; + if (label.collection == Functions_Equals) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_Equals[label.function_num])(params, args); + } + if (label.collection == Functions_LessThan) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_LessThan[label.function_num])(params, args); + } + return TypeInstance::Dispatch(label, params, args); + } + ReturnTuple Call_equals(const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_lessThan(const ParamTuple& params, const ValueTuple& args); +}; +Type_String& CreateType_String(Params<0>::Type params) { + static auto& cache = *new InstanceMap<0,Type_String>(); + auto& cached = cache[params]; + if (!cached) { cached = R_get(new Type_String(CreateCategory_String(), params)); } + return *cached; +} +struct Value_String : public TypeValue { + Value_String(Type_String& p, const PrimString& value) : parent(p), value_(value) {} + ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { + using CallType = ReturnTuple(Value_String::*)(const S&, const ParamTuple&, const ValueTuple&); + static const CallType Table_AsBool[] = { + &Value_String::Call_asBool, + }; + static const CallType Table_Formatted[] = { + &Value_String::Call_formatted, + }; + static const CallType Table_ReadPosition[] = { + &Value_String::Call_readPosition, + &Value_String::Call_readSize, + &Value_String::Call_subSequence, + }; + static const CallType Table_String[] = { + &Value_String::Call_subSequence, + }; + if (label.collection == Functions_AsBool) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_AsBool[label.function_num])(self, params, args); + } + if (label.collection == Functions_Formatted) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_Formatted[label.function_num])(self, params, args); + } + if (label.collection == Functions_ReadPosition) { + if (label.function_num < 0 || label.function_num >= 3) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_ReadPosition[label.function_num])(self, params, args); + } + if (label.collection == Functions_String) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_String[label.function_num])(self, params, args); + } + return TypeValue::Dispatch(self, label, params, args); + } + std::string CategoryName() const final { return parent.CategoryName(); } + const PrimString& AsString() const final { return value_; } + ReturnTuple Call_asBool(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_formatted(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_readPosition(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_readSize(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_subSequence(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + Type_String& parent; + const PrimString value_; +}; +ReturnTuple Type_String::Call_equals(const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("String.equals") + const S& Var_arg1 = (args.At(0)); + const S& Var_arg2 = (args.At(1)); + return ReturnTuple(Box_Bool(Var_arg1->AsString()==Var_arg2->AsString())); +} +ReturnTuple Type_String::Call_lessThan(const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("String.lessThan") + const S& Var_arg1 = (args.At(0)); + const S& Var_arg2 = (args.At(1)); + return ReturnTuple(Box_Bool(Var_arg1->AsString()AsString())); +} +ReturnTuple Value_String::Call_asBool(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("String.asBool") + return ReturnTuple(Box_Bool(value_.size() != 0)); +} +ReturnTuple Value_String::Call_formatted(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("String.formatted") + return ReturnTuple(Var_self); +} +ReturnTuple Value_String::Call_readPosition(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("String.readPosition") + const PrimInt Var_arg1 = (args.At(0))->AsInt(); + if (Var_arg1 < 0 || Var_arg1 >= value_.size()) { + FAIL() << "Read position " << Var_arg1 << " is out of bounds"; + } + return ReturnTuple(Box_Char(value_[Var_arg1])); +} +ReturnTuple Value_String::Call_readSize(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("String.readSize") + return ReturnTuple(Box_Int(value_.size())); +} +ReturnTuple Value_String::Call_subSequence(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("String.subSequence") + const PrimInt Var_arg1 = (args.At(0))->AsInt(); + const PrimInt Var_arg2 = (args.At(1))->AsInt(); + if (Var_arg1 < 0 || Var_arg1 > value_.size()) { + FAIL() << "Subsequence position " << Var_arg1 << " is out of bounds"; + } + if (Var_arg2 < 0 || Var_arg1 + Var_arg2 > value_.size()) { + FAIL() << "Subsequence size " << Var_arg2 << " is invalid"; + } + return ReturnTuple(Box_String(value_.substr(Var_arg1,Var_arg2))); +} +} // namespace +TypeCategory& GetCategory_String() { + return CreateCategory_String(); +} +TypeInstance& GetType_String(Params<0>::Type params) { + return CreateType_String(params); +} +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +} // namespace ZEOLITE_DYNAMIC_NAMESPACE +using namespace ZEOLITE_DYNAMIC_NAMESPACE; +#endif // ZEOLITE_DYNAMIC_NAMESPACE + + +S Box_Bool(bool value) { + return value? Var_true : Var_false; +} + +S Box_Char(PrimChar value) { + return S_get(new Value_Char(CreateType_Char(Params<0>::Type()), value)); +} + +S Box_Int(PrimInt value) { + return S_get(new Value_Int(CreateType_Int(Params<0>::Type()), value)); +} + +S Box_Float(PrimFloat value) { + return S_get(new Value_Float(CreateType_Float(Params<0>::Type()), value)); +} + +S Box_String(const PrimString& value) { + return S_get(new Value_String(CreateType_String(Params<0>::Type()), value)); +} diff --git a/base/builtin.hpp b/base/builtin.hpp new file mode 100644 --- /dev/null +++ b/base/builtin.hpp @@ -0,0 +1,41 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#ifndef BUILTIN_HPP_ +#define BUILTIN_HPP_ + +#include "category-header.hpp" + + +void BuiltinFail(const S& formatted) __attribute__ ((noreturn)); + +TypeInstance& Merge_Intersect(L params); +TypeInstance& Merge_Union(L params); + +TypeInstance& GetMerged_Any(); +TypeInstance& GetMerged_All(); + +S Box_Bool(bool value); +S Box_String(const PrimString& value); +S Box_Char(PrimChar value); +S Box_Int(PrimInt value); +S Box_Float(PrimFloat value); + +extern const S& Var_empty; + +#endif // BUILTIN_HPP_ diff --git a/base/category-header.hpp b/base/category-header.hpp new file mode 100644 --- /dev/null +++ b/base/category-header.hpp @@ -0,0 +1,34 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#ifndef CATEGORY_HEADER_HPP_ +#define CATEGORY_HEADER_HPP_ + +#include + +#include "types.hpp" + + +class TypeCategory; +class TypeInstance; +class TypeValue; +class CategoryFunction; +class TypeFunction; +class ValueFunction; + +#endif // CATEGORY_HEADER_HPP_ diff --git a/base/category-source.cpp b/base/category-source.cpp new file mode 100644 --- /dev/null +++ b/base/category-source.cpp @@ -0,0 +1,154 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#include "category-source.hpp" + +#include "logging.hpp" +#include "builtin.hpp" + + +ReturnTuple TypeCategory::Dispatch(const CategoryFunction& label, + const ParamTuple& params, const ValueTuple& args) { + FAIL() << CategoryName() << " does not implement " << label; + __builtin_unreachable(); +} + +ReturnTuple TypeInstance::Dispatch(const TypeFunction& label, + const ParamTuple& params, const ValueTuple& args) { + FAIL() << CategoryName() << " does not implement " << label; + __builtin_unreachable(); +} + +ReturnTuple TypeValue::Dispatch(const S& self, + const ValueFunction& label, + const ParamTuple& params, const ValueTuple& args) { + FAIL() << CategoryName() << " does not implement " << label; + __builtin_unreachable(); +} + +bool TypeInstance::CanConvert(const TypeInstance& x, const TypeInstance& y) { + if (&x == &y) { + return true; + } + if (x.InstanceMergeType() == MergeType::SINGLE && + y.InstanceMergeType() == MergeType::SINGLE) { + return y.CanConvertFrom(x); + } + return ExpandCheckLeft(x,y); +} + +bool TypeInstance::ExpandCheckLeft(const TypeInstance& x, const TypeInstance& y) { + for (const TypeInstance* left : x.MergedTypes()) { + const bool result = ExpandCheckRight(*left,y); + switch (x.InstanceMergeType()) { + case MergeType::SINGLE: + return result; + case MergeType::UNION: + if (!result) { + return false; + } + break; + case MergeType::INTERSECT: + if (result) { + return true; + } + break; + } + } + switch (x.InstanceMergeType()) { + case MergeType::SINGLE: return false; + case MergeType::UNION: return true; + case MergeType::INTERSECT: return false; + } +} + +bool TypeInstance::ExpandCheckRight(const TypeInstance& x, const TypeInstance& y) { + for (const TypeInstance* right : y.MergedTypes()) { + const bool result = TypeInstance::CanConvert(x,*right); + switch (y.InstanceMergeType()) { + case MergeType::SINGLE: + return result; + case MergeType::UNION: + if (result) { + return true; + } + break; + case MergeType::INTERSECT: + if (!result) { + return false; + } + break; + } + } + switch (y.InstanceMergeType()) { + case MergeType::SINGLE: return false; + case MergeType::UNION: return false; + case MergeType::INTERSECT: return true; + } +} + +bool TypeValue::Present(S target) { + if (target == nullptr) { + FAIL() << "Builtin called on null value"; + } + return target->Present(); +} + +S TypeValue::Require(S target) { + if (target == nullptr) { + FAIL() << "Builtin called on null value"; + } + if (!target->Present()) { + FAIL() << "Cannot require empty value"; + } + return target; +} + +S TypeValue::Strong(W target) { + const auto strong = target.lock(); + return strong? strong : Var_empty; +} + +bool TypeValue::AsBool() const { + FAIL() << CategoryName() << " is not a Bool value"; + __builtin_unreachable(); +} + +const PrimString& TypeValue::AsString() const { + FAIL() << CategoryName() << " is not a String value"; + __builtin_unreachable(); +} + +PrimChar TypeValue::AsChar() const { + FAIL() << CategoryName() << " is not a Char value"; + __builtin_unreachable(); +} + +PrimInt TypeValue::AsInt() const { + FAIL() << CategoryName() << " is not an Int value"; + __builtin_unreachable(); +} + +PrimFloat TypeValue::AsFloat() const { + FAIL() << CategoryName() << " is not a Float value"; + __builtin_unreachable(); +} + +bool TypeValue::Present() const { + return true; +} diff --git a/base/category-source.hpp b/base/category-source.hpp new file mode 100644 --- /dev/null +++ b/base/category-source.hpp @@ -0,0 +1,165 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#ifndef CATEGORY_SOURCE_HPP_ +#define CATEGORY_SOURCE_HPP_ + +#include +#include +#include + +#include "types.hpp" +#include "function.hpp" +#include "builtin.hpp" +#include "argv.hpp" +#include "cycle-check.hpp" + + +class TypeCategory { + public: + inline ReturnTuple Call(const CategoryFunction& label, + const ParamTuple& params, const ValueTuple& args) { + return Dispatch(label, params, args); + } + + virtual std::string CategoryName() const = 0; + + ALWAYS_PERMANENT(TypeCategory) + virtual ~TypeCategory() = default; + + protected: + TypeCategory() = default; + + virtual ReturnTuple Dispatch(const CategoryFunction& label, + const ParamTuple& params, const ValueTuple& args); +}; + +class TypeInstance { + public: + inline ReturnTuple Call(const TypeFunction& label, + ParamTuple params, const ValueTuple& args) { + return Dispatch(label, params, args); + } + + virtual std::string CategoryName() const = 0; + virtual void BuildTypeName(std::ostream& output) const = 0; + + + static std::string TypeName(const TypeInstance& type) { + std::ostringstream output; + type.BuildTypeName(output); + return output.str(); + } + + static S Reduce(TypeInstance& from, TypeInstance& to, S target) { + TRACE_FUNCTION("reduce") + return CanConvert(from, to)? target : Var_empty; + } + + virtual bool TypeArgsForParent( + const TypeCategory& category, std::vector& args) const + { return false; } + + ALWAYS_PERMANENT(TypeInstance) + virtual ~TypeInstance() = default; + + protected: + TypeInstance() = default; + + virtual ReturnTuple Dispatch(const TypeFunction& label, + const ParamTuple& params, const ValueTuple& args); + + virtual bool CanConvertFrom(const TypeInstance& from) const + { return false; } + + static bool CanConvert(const TypeInstance& from, const TypeInstance& to); + + template + static void TypeNameFrom(std::ostream& output, const TypeCategory& category, + const Ts&... params) { + std::vector params2{¶ms...}; + output << category.CategoryName(); + if (!params2.empty()) { + output << "<"; + bool first = true; + for (const auto param : params2) { + if (!first) output << ","; + first = false; + param->BuildTypeName(output); + } + output << ">"; + } + } + + enum class MergeType { + SINGLE, + UNION, + INTERSECT, + }; + + private: + virtual MergeType InstanceMergeType() const + { return MergeType::SINGLE; } + + virtual std::vector MergedTypes() const + { return std::vector{this}; } + + static bool ExpandCheckLeft(const TypeInstance& from, const TypeInstance& to); + static bool ExpandCheckRight(const TypeInstance& from, const TypeInstance& to); +}; + +class TypeValue { + public: + inline static ReturnTuple Call(const S& target, + const ValueFunction& label, + const ParamTuple& params, const ValueTuple& args) { + if (target == nullptr) { + FAIL() << "Function called on null value"; + } + return target->Dispatch(target, label, params, args); + } + + virtual std::string CategoryName() const = 0; + + static bool Present(S target); + static S Require(S target); + static S Strong(W target); + + virtual bool AsBool() const; + virtual const PrimString& AsString() const; + virtual PrimChar AsChar() const; + virtual PrimInt AsInt() const; + virtual PrimFloat AsFloat() const; + + ALWAYS_PERMANENT(TypeValue) + virtual ~TypeValue() = default; + + protected: + TypeValue() = default; + + virtual bool Present() const; + + virtual ReturnTuple Dispatch(const S& self, + const ValueFunction& label, + const ParamTuple& params, const ValueTuple& args); +}; + +template +using InstanceMap = std::map::Type, R>; + +#endif // CATEGORY_SOURCE_HPP_ diff --git a/base/cycle-check.hpp b/base/cycle-check.hpp new file mode 100644 --- /dev/null +++ b/base/cycle-check.hpp @@ -0,0 +1,45 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#ifndef CYCLE_CHECK_HPP_ +#define CYCLE_CHECK_HPP_ + +#include "thread-capture.h" + +#include "logging.hpp" + + +// Type must have a const function CategoryName(). +template +class CycleCheck : public capture_thread::ThreadCapture> { + public: + CycleCheck(const Type& type) : type_(type), capture_to_(this) {} + + static void Check() { + auto current = capture_thread::ThreadCapture>::GetCurrent(); + if (current) { + FAIL() << "Detected cycle in " << current->type_.CategoryName() << " init"; + } + } + + private: + const Type& type_; + const typename capture_thread::ThreadCapture>::ScopedCapture capture_to_; +}; + +#endif // CYCLE_CHECK_HPP_ diff --git a/base/function.hpp b/base/function.hpp new file mode 100644 --- /dev/null +++ b/base/function.hpp @@ -0,0 +1,67 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#ifndef FUNCTION_HPP_ +#define FUNCTION_HPP_ + +#include + + +struct CategoryFunction { + const int param_count; + const int arg_count; + const int return_count; + const char* const category; + const char* const function; + const void* const collection; + const int function_num; +}; + +struct TypeFunction { + const int param_count; + const int arg_count; + const int return_count; + const char* const category; + const char* const function; + const void* const collection; + const int function_num; +}; + +struct ValueFunction { + const int param_count; + const int arg_count; + const int return_count; + const char* const category; + const char* const function; + const void* const collection; + const int function_num; +}; + +inline std::ostream& operator << (std::ostream& output, const CategoryFunction& func) { + return output << func.category << "." << func.function; +} + +inline std::ostream& operator << (std::ostream& output, const TypeFunction& func) { + return output << func.category << "." << func.function; +} + +inline std::ostream& operator << (std::ostream& output, const ValueFunction& func) { + return output << func.category << "." << func.function; +} + +#endif // FUNCTION_HPP_ diff --git a/base/logging.cpp b/base/logging.cpp new file mode 100644 --- /dev/null +++ b/base/logging.cpp @@ -0,0 +1,143 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#include "logging.hpp" + +#include +#include +#include + +#include "argv.hpp" + + +LogThenCrash::LogThenCrash(bool fail, const std::string& condition) + : fail_(fail), signal_(SIGABRT), condition_(condition) {} + +LogThenCrash::LogThenCrash(bool fail, int signal) + : fail_(fail), signal_(signal) {} + +LogThenCrash::~LogThenCrash() { + if (fail_) { + std::signal(signal_, SIG_DFL); + if (Argv::ArgCount() > 0) { + std::cerr << Argv::GetArgAt(0) << ": "; + } + std::cerr << "Failed condition"; + if (!condition_.empty()) { + std::cerr << " '" << condition_ << "'"; + } + std::cerr << ": " << output_.str() << std::endl; + for (const auto& trace : TraceContext::GetTrace()) { + if (!trace.empty()) { + std::cerr << " " << trace << std::endl; + } + } + std::raise(signal_); + } +} + +// TODO: Should only be available used if POSIX is defined. +void TraceOnSignal(int signal) { + LogThenCrash(true,signal) << "Recieved signal " << signal; +} + +// TODO: Should only be available used if POSIX is defined. +void SetSignalHandler() { +#ifdef SIGINT + std::signal(SIGINT, &TraceOnSignal); +#endif +#ifdef SIGILL + std::signal(SIGILL, &TraceOnSignal); +#endif +#ifdef SIGABRT + std::signal(SIGABRT, &TraceOnSignal); +#endif +#ifdef SIGFPE + std::signal(SIGFPE, &TraceOnSignal); +#endif +#ifdef SIGQUIT + std::signal(SIGQUIT, &TraceOnSignal); +#endif +#ifdef SIGSEGV + std::signal(SIGSEGV, &TraceOnSignal); +#endif +#ifdef SIGPIPE + std::signal(SIGPIPE, &TraceOnSignal); +#endif +#ifdef SIGALRM + std::signal(SIGALRM, &TraceOnSignal); +#endif +#ifdef SIGTERM + std::signal(SIGTERM, &TraceOnSignal); +#endif +#ifdef SIGUSR1 + std::signal(SIGUSR1, &TraceOnSignal); +#endif +#ifdef SIGUSR2 + std::signal(SIGUSR2, &TraceOnSignal); +#endif +} + + +std::list TraceContext::GetTrace() { + std::list trace; + const TraceContext* current = GetCurrent(); + while (current) { + current->AppendTrace(trace); + current = current->GetNext(); + } + return trace; +} + + +void SourceContext::SetLocal(const char* at) { + at_ = at; +} + +void SourceContext::AppendTrace(std::list& trace) const { + std::ostringstream output; + if (at_ == nullptr || at_[0] == 0x00) { + output << "From " << name_; + } else { + output << "From " << name_ << " at " << at_; + } + trace.push_back(output.str()); +} + +const TraceContext* SourceContext::GetNext() const { + return cross_and_capture_to_.Previous(); +} + + +void CleanupContext::SetLocal(const char* at) { + at_ = at; +} + +void CleanupContext::AppendTrace(std::list& trace) const { + std::ostringstream output; + if (at_ == nullptr || at_[0] == 0x00) { + output << "In cleanup block"; + } else { + output << "In cleanup block at " << at_; + } + trace.push_back(output.str()); +} + +const TraceContext* CleanupContext::GetNext() const { + return cross_and_capture_to_.Previous(); +} diff --git a/base/logging.hpp b/base/logging.hpp new file mode 100644 --- /dev/null +++ b/base/logging.hpp @@ -0,0 +1,137 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#ifndef LOGGING_HPP_ +#define LOGGING_HPP_ + +#include +#include +#include + +#include "thread-capture.h" + + +#define FAIL() LogThenCrash(true) + +void SetSignalHandler(); + +class LogThenCrash { + public: + LogThenCrash(bool fail, const std::string& condition = ""); + LogThenCrash(bool fail, int signal); + ~LogThenCrash(); + + template + LogThenCrash& operator << (const T& stuff) { + if (fail_) { + static_cast(output_) << stuff; + } + return *this; + } + + private: + LogThenCrash(const LogThenCrash&) = delete; + LogThenCrash(LogThenCrash&&) = delete; + LogThenCrash& operator =(const LogThenCrash&) = delete; + LogThenCrash& operator =(LogThenCrash&&) = delete; + void* operator new(std::size_t size) = delete; + + const bool fail_; + const int signal_; + const std::string condition_; + std::ostringstream output_; +}; + + +#ifndef DISABLE_TRACING + + #define TRACE_FUNCTION(name) \ + SourceContext source_context(name); + + #define TRACE_CLEANUP \ + CleanupContext cleanup_context; + + #define SET_CONTEXT_POINT(point) \ + TraceContext::SetContext(point); + + #define PRED_CONTEXT_POINT(point) \ + TraceContext::SetContext(point), + +#else + + #define TRACE_FUNCTION(name) + + #define TRACE_CLEANUP + + #define SET_CONTEXT_POINT(point) + + #define PRED_CONTEXT_POINT(point) + +#endif + +class TraceContext : public capture_thread::ThreadCapture { + public: + static std::list GetTrace(); + + template + static inline void SetContext(const char(&at)[S]) { + if (GetCurrent()) { + GetCurrent()->SetLocal(at); + } + } + + protected: + virtual ~TraceContext() = default; + + private: + virtual void SetLocal(const char*) = 0; + virtual void AppendTrace(std::list& trace) const = 0; + virtual const TraceContext* GetNext() const = 0; +}; + +class SourceContext : public TraceContext { + public: + template + inline SourceContext(const char(&name)[S]) + : at_(nullptr), name_(name), cross_and_capture_to_(this) {} + + private: + void SetLocal(const char*) final; + void AppendTrace(std::list& trace) const final; + const TraceContext* GetNext() const final; + + const char* at_; + const char* const name_; + const AutoThreadCrosser cross_and_capture_to_; +}; + +class CleanupContext : public TraceContext { + public: + inline CleanupContext() + : at_(nullptr), cross_and_capture_to_(this) {} + + private: + void SetLocal(const char*) final; + void AppendTrace(std::list& trace) const final; + const TraceContext* GetNext() const final; + + const char* at_; + const AutoThreadCrosser cross_and_capture_to_; +}; + +#endif // LOGGING_HPP_ diff --git a/base/types.cpp b/base/types.cpp new file mode 100644 --- /dev/null +++ b/base/types.cpp @@ -0,0 +1,76 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#include "types.hpp" + +#include "logging.hpp" + + +int ArgTuple::Size() const { + return args_.size(); +} + +const S& ArgTuple::At(int pos) const { + if (pos < 0 || pos >= args_.size()) { + FAIL() << "Bad ArgTuple index"; + } + return *args_[pos]; +} + +const S& ArgTuple::Only() const { + if (args_.size() != 1) { + FAIL() << "Bad ArgTuple index"; + } + return *args_[0]; +} + +int ReturnTuple::Size() const { + return returns_.size(); +} + +S& ReturnTuple::At(int pos) { + if (pos < 0 || pos >= returns_.size()) { + FAIL() << "Bad ReturnTuple index"; + } + return returns_[pos]; +} + +const S& ReturnTuple::At(int pos) const { + if (pos < 0 || pos >= returns_.size()) { + FAIL() << "Bad ReturnTuple index"; + } + return returns_[pos]; +} + +const S& ReturnTuple::Only() const { + if (returns_.size() != 1) { + FAIL() << "Bad ReturnTuple index"; + } + return returns_[0]; +} + +int ParamTuple::Size() const { + return params_.size(); +} + +TypeInstance* ParamTuple::At(int pos) const { + if (pos < 0 || pos >= params_.size()) { + FAIL() << "Bad ParamTuple index"; + } + return params_[pos]; +} diff --git a/base/types.hpp b/base/types.hpp new file mode 100644 --- /dev/null +++ b/base/types.hpp @@ -0,0 +1,203 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#ifndef TYPES_HPP_ +#define TYPES_HPP_ + +#include +#include +#include +#include +#include + +#include "logging.hpp" + + +#define ALWAYS_PERMANENT(type) \ + type(const type&) = delete; \ + type(type&&) = delete; \ + type& operator =(const type&) = delete; \ + type& operator =(type&&) = delete; + +using PrimInt = std::int64_t; +using PrimString = std::string; +using PrimChar = char; +using PrimFloat = double; + +template +inline PrimString PrimString_FromLiteral(const char(&literal)[S]) { + return PrimString(literal, literal + (S - 1)); +} + +template +using R = std::unique_ptr; + +template +inline R R_get(T* val) { return R(val); } + +template +using S = std::shared_ptr; + +template +inline S S_get(T* val) { return S(val); } + +template +using W = std::weak_ptr; + +template +inline W W_get(T* val) { return W(val); } + +template +using T = std::tuple; + +template +T T_get(Ts... ts) { return std::make_tuple(ts...); } + +template +using L = std::vector; + +template +inline L L_get(Ts... ts) { return L{ts...}; } + +template +class LazyInit { + public: + LazyInit(const std::function& create) + : initialized_(false), pending_(false), value_(), create_(create) {} + + const T& Get() { + InitValue(); + return value_; + } + + LazyInit& operator = (const T& value) { + InitValue(); + value_ = value; + return *this; + } + + private: + LazyInit(const LazyInit&) = delete; + LazyInit(LazyInit&&) = delete; + LazyInit& operator = (const LazyInit&) = delete; + LazyInit& operator = (LazyInit&&) = delete; + + void InitValue() { + if (pending_) { + FAIL() << "Cycle in lazy initialization"; + } + if (!initialized_) { + pending_ = true; + value_ = create_(); + pending_ = false; + initialized_ = true; + } + } + + bool initialized_, pending_; + T value_; + const std::function create_; +}; + + +class TypeCategory; +class TypeInstance; +class TypeValue; + +template +struct Params { + using Type = typename Params::Type; +}; + +template +struct Params<0, Ts...> { + using Type = T; +}; + + +class ValueTuple { + public: + virtual int Size() const = 0; + virtual const S& At(int pos) const = 0; + virtual const S& Only() const = 0; + + protected: + ValueTuple() = default; + virtual ~ValueTuple() = default; + + private: + void* operator new(std::size_t size) = delete; +}; + +class ReturnTuple : public ValueTuple { + public: + ReturnTuple(int size) : returns_(size) {} + + ReturnTuple(ReturnTuple&&) = default; + ReturnTuple& operator =(ReturnTuple&&) = default; + + template + explicit ReturnTuple(Ts... returns) : returns_{std::move(returns)...} {} + + int Size() const final; + S& At(int pos); + const S& At(int pos) const final; + const S& Only() const final; + + private: + ReturnTuple(const ReturnTuple&) = delete; + ReturnTuple& operator =(const ReturnTuple&) = delete; + + std::vector> returns_; +}; + +class ArgTuple : public ValueTuple { + public: + template + explicit ArgTuple(const Ts&... args) : args_{&args...} {} + + int Size() const final; + const S& At(int pos) const final; + const S& Only() const final; + + private: + ArgTuple(const ArgTuple&) = delete; + ArgTuple& operator =(const ArgTuple&) = delete; + + std::vector*> args_; +}; + +class ParamTuple { + public: + ParamTuple(ParamTuple&& other) : params_(std::move(other.params_)) {} + + template + explicit ParamTuple(Ts*... args) : params_{args...} {} + + int Size() const; + TypeInstance* At(int pos) const; + + private: + ParamTuple(const ParamTuple&) = delete; + ParamTuple& operator =(const ParamTuple&) = delete; + void* operator new(std::size_t size) = delete; + + std::vector params_; +}; + +#endif // TYPES_HPP_ diff --git a/bin/unit-tests.hs b/bin/unit-tests.hs new file mode 100644 --- /dev/null +++ b/bin/unit-tests.hs @@ -0,0 +1,41 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +import Base.CompileError +import Compilation.CompileInfo +import Test.Common +import qualified Test.DefinedCategory as DefinedCategoryTest +import qualified Test.IntegrationTest as IntegrationTestTest +import qualified Test.Parser as ParserTest +import qualified Test.Procedure as ProcedureTest +import qualified Test.TypeCategory as TypeCategoryTest +import qualified Test.TypeInstance as TypeInstanceTest + + +main = runAllTests $ concat [ + labelWith "DefinedCategoryTest" DefinedCategoryTest.tests, + labelWith "TypeInstanceTest" TypeInstanceTest.tests, + labelWith "ParserTest" ParserTest.tests, + labelWith "TypeCategoryTest" TypeCategoryTest.tests, + labelWith "ProcedureTest" ProcedureTest.tests, + labelWith "IntegrationTestTest" IntegrationTestTest.tests + ] + +labelWith s ts = map (\(n,t) -> fmap (`reviseError` ("In " ++ s ++ " (#" ++ show n ++ "):")) t) (zip [1..] ts) diff --git a/bin/zeolite-setup.hs b/bin/zeolite-setup.hs new file mode 100644 --- /dev/null +++ b/bin/zeolite-setup.hs @@ -0,0 +1,127 @@ +{- ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +import Control.Monad (when) +import System.Directory +import System.Exit +import System.FilePath +import System.IO + +import Cli.CompileOptions +import Cli.Compiler +import Config.LoadConfig +import Config.Paths +import Config.Programs + + +main = do + f <- localConfigPath + isFile <- doesFileExist f + when isFile $ do + hPutStrLn stderr $ "*** WARNING: Local config " ++ f ++ " will be overwritten. ***" + config <- createConfig + f <- localConfigPath + hPutStrLn stderr $ "Writing local config to " ++ f ++ "." + writeFile f (show config ++ "\n") + initLibraries + hPutStrLn stderr "Setup is now complete!" + +clangBinary = "clang++" +gccBinary = "g++" +arBinary = "ar" +libraries = [ + "base", + "lib/util", + "lib/file", + "tests/visibility/internal", + "tests/visibility", + "tests/visibility2/internal", + "tests/visibility2", + "tests" + ] + +createConfig :: IO LocalConfig +createConfig = do + clang <- findExecutables clangBinary + gcc <- findExecutables gccBinary + ar <- findExecutables arBinary + compiler <- promptChoice "Which clang-compatible C++ compiler should be used?" (clang ++ gcc) + archiver <- promptChoice "Which ar-compatible archiver should be used?" ar + -- Cannot be overridden at this point. + let options = ["-O2", "-std=c++11"] + let config = LocalConfig { + lcBackend = UnixBackend { + ucCxxBinary = compiler, + ucCxxOptions = options, + ucArBinary = archiver + }, + lcResolver = SimpleResolver + } + return config + +promptChoice :: String -> [String] -> IO String +promptChoice p cs = do + n <- getChoice + if n <= length cs + then return $ cs !! (n-1) + else getResponse + where + getChoice = do + hPutStrLn stderr p + let cs' = zipWith (\n c -> show n ++ ") " ++ c) [1..] $ cs ++ ["other"] + let cs'' = (head cs' ++ " [default]"):(tail cs') + mapM_ (hPutStrLn stderr) cs'' + hPutStr stderr "? " + n <- getInput + if null n + then return 1 + else case check (reads n :: [(Int,String)]) of + Just n' | n' > 0 && n' <= length cs' -> return n' + _ -> getChoice + getResponse = do + hPutStrLn stderr "Enter the full path: " + getInput + check [(cm,"")] = Just cm + check _ = Nothing + +getInput :: IO String +getInput = do + closed <- hIsEOF stdin + when closed $ do + hPutStrLn stderr "Canceled." + exitFailure + hGetLine stdin + +initLibraries :: IO () +initLibraries = do + path <- rootPath >>= canonicalizePath + let libraries' = map (path ) libraries + let options = CompileOptions { + coHelp = HelpNotNeeded, + coPublicDeps = [], + coPrivateDeps = [], + coSources = libraries', + coExtraFiles = [], + coExtraPaths = [], + coExtraRequires = [], + coSourcePrefix = "", + coMode = CompileRecompile, + coOutputName = "", + coForce = ForceRecompile + } + runCompiler options diff --git a/bin/zeolite.hs b/bin/zeolite.hs new file mode 100644 --- /dev/null +++ b/bin/zeolite.hs @@ -0,0 +1,50 @@ +{- ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +import Control.Monad (when) +import System.Environment +import System.Exit +import System.FilePath +import System.IO + +import Base.CompileError +import Cli.CompileOptions +import Cli.Compiler +import Cli.ParseCompileOptions -- Not safe, due to Text.Regex.TDFA. +import Compilation.CompileInfo + + +main = do + args <- getArgs + let options = parseCompileOptions args >>= validateCompileOptions + compile options where + compile co + | isCompileError co = do + hPutStr stderr $ show $ getCompileError co + hPutStrLn stderr "Use the -h option to show help." + exitFailure + | otherwise = do + let co' = getCompileSuccess co + when (HelpNotNeeded /= (coHelp co')) $ showHelp >> exitFailure + runCompiler co' + +showHelp :: IO () +showHelp = do + hPutStrLn stderr "Zeolite CLI Help:" + mapM_ (hPutStrLn stderr . (" " ++)) optionHelpText + hPutStrLn stderr "Also see https://ta0kira.github.io/zeolite for more documentation." diff --git a/capture-thread/include/thread-capture.h b/capture-thread/include/thread-capture.h new file mode 100644 --- /dev/null +++ b/capture-thread/include/thread-capture.h @@ -0,0 +1,217 @@ +/* ----------------------------------------------------------------------------- +Copyright 2017 Google Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] [kevinbarry@google.com] + +#ifndef THREAD_CAPTURE_H_ +#define THREAD_CAPTURE_H_ + +#include + +#include "thread-crosser.h" + +namespace capture_thread { + +// Base class for instrumentation classes that need to be made available within +// a single thread, and possibly shared across threads. Derive a new class Type +// from ThreadCapture to define a new instrumentation type. Scoping is +// managed by adding a ScopedCapture *or* an AutoThreadCrosser member to +// instantiable implementations of the instrumentation. (If Type is abstract, +// add the member to the instantiable subclasses.) See ThreadCrosser for info +// about *automatic* sharing across threads, and ThreadBridge (below) for info +// about *manually* sharing across threads. +template +class ThreadCapture { + protected: + ThreadCapture() = default; + virtual ~ThreadCapture() = default; + + class CrossThreads; + + // Manages scoping of instrumentation within a single thread. Use ThreadBridge + // + CrossThreads to share instrumentation across threads. Alternatively, use + // AutoThreadCrosser *instead* of ScopedCapture to allow ThreadCrosser to + // handle this automatically. + class ScopedCapture { + public: + explicit inline ScopedCapture(Type* capture) + : previous_(GetCurrent()), current_(capture) { + SetCurrent(current_); + } + + inline ~ScopedCapture() { SetCurrent(Previous()); } + + inline Type* Previous() const { return previous_; } + + private: + ScopedCapture(const ScopedCapture&) = delete; + ScopedCapture(ScopedCapture&&) = delete; + ScopedCapture& operator=(const ScopedCapture&) = delete; + ScopedCapture& operator=(ScopedCapture&&) = delete; + void* operator new(std::size_t size) = delete; + + friend class CrossThreads; + Type* const previous_; + Type* const current_; + }; + + // Creates a bridge point for sharing a single type of instrumentation between + // threads. Create this in the main thread, then enable crossing in the worker + // thread with CrossThreads. This is only needed if the instrumentation uses + // ScopedCapture instead of AutoThreadCrosser. + // + // NOTE: This isn't visible by default. If you want to make this functionality + // available for a specific instrumentation class, add the following with + // public visibility within the instrumentation class: + // + // using ThreadCapture::ThreadBridge; + class ThreadBridge { + public: + inline ThreadBridge() : capture_(GetCurrent()) {} + + private: + ThreadBridge(const ThreadBridge&) = delete; + ThreadBridge(ThreadBridge&&) = delete; + ThreadBridge& operator=(const ThreadBridge&) = delete; + ThreadBridge& operator=(ThreadBridge&&) = delete; + void* operator new(std::size_t size) = delete; + + friend class CrossThreads; + Type* const capture_; + }; + + class AutoThreadCrosser; + + // Connects a worker thread to the main thread via a ThreadBridge for manually + // sharing of a single type of instrumentation. + // + // NOTE: This isn't visible by default. If you want to make this functionality + // available for a specific instrumentation class, add the following with + // public visibility within the instrumentation class: + // + // using ThreadCapture::CrossThreads; + class CrossThreads { + public: + explicit inline CrossThreads(const ThreadBridge& bridge) + : previous_(GetCurrent()) { + SetCurrent(bridge.capture_); + } + + inline ~CrossThreads() { SetCurrent(previous_); } + + private: + explicit inline CrossThreads(const ScopedCapture& capture) + : previous_(GetCurrent()) { + SetCurrent(capture.current_); + } + + CrossThreads(const CrossThreads&) = delete; + CrossThreads(CrossThreads&&) = delete; + CrossThreads& operator=(const CrossThreads&) = delete; + CrossThreads& operator=(CrossThreads&&) = delete; + void* operator new(std::size_t size) = delete; + + friend class AutoThreadCrosser; + Type* const previous_; + }; + + // Enables automatic crossing of threads for a specific instrumentation type + // when ThreadCrosser::WrapCall or ThreadCrosser::WrapFunction are used. Add + // this as a member of the implementation that you want to automatically + // share. Use ScopedCapture *instead* if you don't want ThreadCrosser to + // automatically share instrumentation. + class AutoThreadCrosser : public ThreadCrosser { + public: + AutoThreadCrosser(Type* capture) + : cross_with_(this), capture_to_(capture) {} + + inline Type* Previous() const { return capture_to_.Previous(); } + + private: + AutoThreadCrosser(const AutoThreadCrosser&) = delete; + AutoThreadCrosser(AutoThreadCrosser&&) = delete; + AutoThreadCrosser& operator=(const AutoThreadCrosser&) = delete; + AutoThreadCrosser& operator=(AutoThreadCrosser&&) = delete; + void* operator new(std::size_t size) = delete; + + void FindTopAndCall(const std::function& call, + const ReverseScope& reverse_scope) const final; + + void ReconstructContextAndCall( + const std::function& call, + const ReverseScope& reverse_scope) const final; + + const ScopedCrosser cross_with_; + const ScopedCapture capture_to_; + }; + + // Gets the most-recent object from the stack of the current thread. + static inline Type* GetCurrent() { return current_; } + + private: + ThreadCapture(const ThreadCapture&) = delete; + ThreadCapture(ThreadCapture&&) = delete; + ThreadCapture& operator=(const ThreadCapture&) = delete; + ThreadCapture& operator=(ThreadCapture&&) = delete; + void* operator new(std::size_t size) = delete; + + static inline void SetCurrent(Type* value) { current_ = value; } + + static thread_local Type* current_; +}; + +template +thread_local Type* ThreadCapture::current_(nullptr); + +template +void ThreadCapture::AutoThreadCrosser::FindTopAndCall( + const std::function& call, + const ReverseScope& reverse_scope) const { + if (cross_with_.Parent()) { + cross_with_.Parent()->FindTopAndCall( + call, {cross_with_.Parent(), &reverse_scope}); + } else { + ReconstructContextAndCall(call, reverse_scope); + } +} + +template +void ThreadCapture::AutoThreadCrosser::ReconstructContextAndCall( + const std::function& call, + const ReverseScope& reverse_scope) const { + // Makes the ThreadCapture available in this scope so that it overrides the + // default behavior of instrumentation calls made in call. + const CrossThreads capture(capture_to_); + if (reverse_scope.previous) { + const auto current = reverse_scope.previous->current; + assert(current); + if (current) { + current->ReconstructContextAndCall(call, *reverse_scope.previous); + } + } else { + // Makes the ThreadCrosser available in this scope so that call itself can + // cross threads again. + const DelegateCrosser crosser(cross_with_); + assert(call); + if (call) { + call(); + } + } +} + +} // namespace capture_thread + +#endif // THREAD_CAPTURE_H_ diff --git a/capture-thread/include/thread-crosser.h b/capture-thread/include/thread-crosser.h new file mode 100644 --- /dev/null +++ b/capture-thread/include/thread-crosser.h @@ -0,0 +1,254 @@ +/* ----------------------------------------------------------------------------- +Copyright 2017 Google Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] [kevinbarry@google.com] + +#ifndef THREAD_CROSSER_H_ +#define THREAD_CROSSER_H_ + +#include +#include + +#include + +namespace capture_thread { + +// Manages automatic thread-crossing for sharing instrumentation classes derived +// from ThreadCapture. The static API allows the caller to automatically share +// all instrumentation types that are in scope, provided they use +// AutoThreadCrosser to manage scoping. Not all classes will have this enabled, +// since it can cause unexpected results. +class ThreadCrosser { + public: + // Wraps a callback to share instrumentation that's currently in scope with a + // worker thread. Call this in the main thread, then pass the returned value + // to the worker thread. + // + // NOTE: The returned function will be invalidated if any instrumentation goes + // out of scope; therefore, the main thread must wait for the worker thread to + // call it before continuing. + static inline std::function WrapCall(std::function call) { + return WrapFunction(std::move(call)); + } + + // Wraps an arbitrary function to share instrumentation that's currently in + // scope with a worker thread. Call this in the main thread, then pass the + // returned value to the worker thread. + // + // NOTE: The returned function will be invalidated if any instrumentation goes + // out of scope; therefore, the main thread must wait for the worker thread to + // call it before continuing. + template + static inline std::function WrapFunction( + Return (*function)(Args...)) { + return WrapFunction(std::function(function)); + } + + // Wraps an arbitrary function to share instrumentation that's currently in + // scope with a worker thread. Call this in the main thread, then pass the + // returned value to the worker thread. + // + // NOTE: The returned function will be invalidated if any instrumentation goes + // out of scope; therefore, the main thread must wait for the worker thread to + // call it before continuing. + template + static std::function WrapFunction( + std::function function); + + private: + ThreadCrosser(const ThreadCrosser&) = delete; + ThreadCrosser(ThreadCrosser&&) = delete; + ThreadCrosser& operator=(const ThreadCrosser&) = delete; + ThreadCrosser& operator=(ThreadCrosser&&) = delete; + void* operator new(std::size_t size) = delete; + + ThreadCrosser() = default; + virtual ~ThreadCrosser() = default; + + // Keeps track of a reverse call stack when wrapping a callback. (This is used + // to create a linked-list of ThreadCrosser on the stack.) + struct ReverseScope { + const ThreadCrosser* const current; + const ReverseScope* const previous; + }; + + // Performs the function call in the full ThreadCapture context above this + // ThreadCrosser. + inline void CallInFullContext(const std::function& call) const { + FindTopAndCall(call, {this, nullptr}); + } + + // Traverses to the top of the ThreadCrosser stack to recursively rebuild the + // stack of ThreadCapture, then calls the callback. + virtual void FindTopAndCall(const std::function& call, + const ReverseScope& reverse_scope) const = 0; + + // Instantiates the ThreadCapture context associated with this ThreadCrosser, + // then recursively calls the next ThreadCrosser. + virtual void ReconstructContextAndCall( + const std::function& call, + const ReverseScope& reverse_scope) const = 0; + + class ScopedCrosser; + + // Makes a captured ThreadCrosser available within the current thread. This is + // only to allow thread-crossing to happen again within that thread. + class DelegateCrosser { + public: + explicit inline DelegateCrosser(const ScopedCrosser& crosser) + : parent_(GetCurrent()) { + SetCurrent(crosser.current_); + } + + inline ~DelegateCrosser() { SetCurrent(parent_); } + + private: + DelegateCrosser(const DelegateCrosser&) = delete; + DelegateCrosser(DelegateCrosser&&) = delete; + DelegateCrosser& operator=(const DelegateCrosser&) = delete; + DelegateCrosser& operator=(DelegateCrosser&&) = delete; + void* operator new(std::size_t size) = delete; + + ThreadCrosser* const parent_; + }; + + // Captures the ThreadCrosser so it can be used by DelegateCrosser, which will + // make it available in another thread. + class ScopedCrosser { + public: + explicit inline ScopedCrosser(ThreadCrosser* capture) + : parent_(GetCurrent()), current_(capture) { + SetCurrent(capture); + } + + inline ~ScopedCrosser() { SetCurrent(Parent()); } + + inline ThreadCrosser* Parent() const { return parent_; } + + private: + ScopedCrosser(const ScopedCrosser&) = delete; + ScopedCrosser(ScopedCrosser&&) = delete; + ScopedCrosser& operator=(const ScopedCrosser&) = delete; + ScopedCrosser& operator=(ScopedCrosser&&) = delete; + void* operator new(std::size_t size) = delete; + + friend class DelegateCrosser; + ThreadCrosser* const parent_; + ThreadCrosser* const current_; + }; + + // AutoMove (and its specializations) ensure that argument-passing when + // calling a std::function doesn't make copies when it would be inappropriate, + // e.g., when Type cannot be copied or moved. This is a class instead of a + // function so that Type can be made explicit, which is necessary for type- + // checking to work. + + template + struct AutoMove; + + // AutoCall (and its specializations) ensure that return values are not + // inappropriately copied, e.g., when returning by reference, or when the + // return type is void. This is a class instead of a function so that the + // types can be made explicit, which is necessary for type-checking to work. + + template + struct AutoCall; + + static ThreadCrosser* GetCurrent(); + static void SetCurrent(ThreadCrosser* value); + + template + friend class ThreadCapture; +}; + +template +std::function ThreadCrosser::WrapFunction( + std::function function) { + const auto current = GetCurrent(); + if (function && current) { + return [current, function](Args... args) -> Return { + return AutoCall::Execute(*current, function, + AutoMove::Pass(args)...); + }; + } else { + return function; + } +} + +// Handles pass-by-value. +template +struct ThreadCrosser::AutoMove { + static Type&& Pass(Type& value) { return std::move(value); } +}; + +// Handles pass-by-reference. +template +struct ThreadCrosser::AutoMove { + static Type& Pass(Type& value) { return value; } +}; + +// Handles return-by-value. +template +struct ThreadCrosser::AutoCall { + static Return Execute(const ThreadCrosser& current, + const std::function& function, + Args... args) { + typename std::remove_cv::type value = Return(); + current.CallInFullContext([&value, &function, &args...] { + value = function(AutoMove::Pass(args)...); + }); + return value; + } +}; + +// Handles return-by-reference. +template +struct ThreadCrosser::AutoCall { + static Return& Execute(const ThreadCrosser& current, + const std::function& function, + Args... args) { + Return* value(nullptr); + current.CallInFullContext([&value, &function, &args...] { + value = &function(AutoMove::Pass(args)...); + }); + assert(value); + return *value; + } +}; + +// Handles void return type. +template +struct ThreadCrosser::AutoCall { + static void Execute(const ThreadCrosser& current, + const std::function& function, + Args... args) { + current.CallInFullContext( + [&function, &args...] { function(AutoMove::Pass(args)...); }); + } +}; + +// Handles callback type. +template <> +struct ThreadCrosser::AutoCall { + static void Execute(const ThreadCrosser& current, + const std::function& function) { + current.CallInFullContext(function); + } +}; + +} // namespace capture_thread + +#endif // THREAD_CROSSER_H_ diff --git a/capture-thread/src/thread-crosser.cc b/capture-thread/src/thread-crosser.cc new file mode 100644 --- /dev/null +++ b/capture-thread/src/thread-crosser.cc @@ -0,0 +1,33 @@ +/* ----------------------------------------------------------------------------- +Copyright 2017 Google Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] [kevinbarry@google.com] + +#include "thread-crosser.h" + +namespace capture_thread { + +namespace { +thread_local ThreadCrosser* current(nullptr); +} + +// static +ThreadCrosser* ThreadCrosser::GetCurrent() { return current; } + +// static +void ThreadCrosser::SetCurrent(ThreadCrosser* value) { current = value; } + +} // namespace capture_thread diff --git a/example/hello/README.md b/example/hello/README.md new file mode 100644 --- /dev/null +++ b/example/hello/README.md @@ -0,0 +1,14 @@ +# Zeolite Hello Example + +To run the example: + +```shell +# This is just to locate the example code. Not for normal use! +ZEOLITE_PATH=$(zeolite --get-path) + +# Compile the example. +zeolite -i lib/util -p "$ZEOLITE_PATH" -m HelloDemo example/hello + +# Execute the compiled binary. +./HelloDemo +``` diff --git a/example/hello/hello-demo.0rx b/example/hello/hello-demo.0rx new file mode 100644 --- /dev/null +++ b/example/hello/hello-demo.0rx @@ -0,0 +1,28 @@ +concrete HelloDemo { + @type run () -> () +} + +define HelloDemo { + run () { + scoped { + TextReader reader <- TextReader$fromBlockReader(SimpleInput$stdin()) + } cleanup { + ~ LazyStream$new() + .append("Goodbye.\n") + .writeTo(SimpleOutput$stderr()) + } in while (!reader.pastEnd()) { + ~ LazyStream$new() + .append("What is your name? ") + .writeTo(SimpleOutput$stderr()) + String name <- reader.readNextLine() + if (name.readSize() == 0) { + break + } + ~ LazyStream$new() + .append("Hello \"") + .append(name) + .append("\", if that's your real name.\n") + .writeTo(SimpleOutput$stderr()) + } + } +} diff --git a/example/regex/README.md b/example/regex/README.md new file mode 100644 --- /dev/null +++ b/example/regex/README.md @@ -0,0 +1,20 @@ +# Zeolite Regex Example + +*Also see +[a highlighted version of the example code](https://ta0kira.github.io/zeolite/example/regex/index.html).* + +To run the example: + +```shell +# This is just to locate the example code. Not for normal use! +ZEOLITE_PATH=$(zeolite --get-path) + +# Compile the example. +zeolite -p "$ZEOLITE_PATH" -i lib/util -m RegexDemo example/regex + +# Run the unit tests. +zeolite -p "$ZEOLITE_PATH" -t example/regex + +# Execute the compiled binary. +./RegexDemo +``` diff --git a/example/regex/char-regex.0rp b/example/regex/char-regex.0rp new file mode 100644 --- /dev/null +++ b/example/regex/char-regex.0rp @@ -0,0 +1,4 @@ +concrete CharRegex { + @type parse (String) -> (optional MatcherTemplate) + @type match (MatcherTemplate,String) -> (Bool) +} diff --git a/example/regex/char-regex.0rx b/example/regex/char-regex.0rx new file mode 100644 --- /dev/null +++ b/example/regex/char-regex.0rx @@ -0,0 +1,199 @@ +define CharRegex { + parse (pattern) (matcher) { + ReadIterator p <- ReadIterator$$fromReadPosition(pattern) + // TODO: Needs error handling. + { _, matcher } <- parseExpression(p) + } + + match (template,data) { + ReadIterator p <- ReadIterator$$fromReadPosition(data) + Matcher matcher <- template.newMatcher() + while (!p.pastForwardEnd()) { + MatchState state <- matcher.tryNextMatch(p.readCurrent()) + if (state `MatchState$equals` MatchState$matchFail()) { + break + } + p <- p.forward() + if (state `MatchState$equals` MatchState$matchComplete()) { + break + } + } + return p.pastForwardEnd() && matcher.matchSatisfied() + } + + @type parseSequence (ReadIterator) -> + (ReadIterator,optional ReadSequence>) + parseSequence (p) { + if (p.pastForwardEnd()) { + return { p, empty } + } + { ReadIterator p2, optional MatcherTemplate matcher } <- parseNonSequence(p) + if (!p2.pastForwardEnd() && (p2.readCurrent() == '|' || p2.readCurrent() == ')')) { + // Requires choice matching or the end of a subexpression. + if (present(matcher)) { + return { p2, LinkedNode>$create(require(matcher),empty) } + } else { + // TODO: Disregards errors from parseNonSequence. + return { p2, LinkedNode>$create(MatchEmpty$create(),empty) } + } + } if (!present(matcher)) { + return { p2, empty } + } else { + { p2, optional ReadSequence> sequence } <- parseSequence(p2) + return { p2, LinkedNode>$create(require(matcher),sequence) } + } + } + + @type parseNonSequence (ReadIterator) -> + (ReadIterator,optional MatcherTemplate) + parseNonSequence (p) (p2,matcher) { + p2 <- p + matcher <- empty + while (!p2.pastForwardEnd()) { + Char c <- p2.readCurrent() + if (c == '|' || c == ')') { + // Requires choice matching or the end of a subexpression. + return _ + } elif (c == '*') { + // TODO: Needs error handling. + return { p2.forward(), + MatchBranches$create(BranchRepeat$createZeroPlus(require(matcher))) } + } elif (c == '+') { + // TODO: Needs error handling. + return { p2.forward(), + MatchBranches$create(BranchRepeat$createOnePlus(require(matcher))) } + } elif (c == '{') { + { p2, Int min, Int max } <- parseRange(p2.forward()) + if (p2.pastForwardEnd() || p2.readCurrent() != '}') { + // TODO: Needs error handling. + fail("missing }") + } + return { p2.forward(), + MatchBranches$create(BranchRepeat$createRange(min,max,require(matcher))) } + } elif (present(matcher)) { + return _ + } elif (c == '[') { + { p2, matcher } <- parseCharChoices(p2.forward()) + if (p2.pastForwardEnd() || p2.readCurrent() != ']') { + // TODO: Needs error handling. + fail("missing ]") + } + p2 <- p2.forward() + } elif (c == '(') { + { p2, matcher } <- parseExpression(p2.forward()) + if (p2.pastForwardEnd() || p2.readCurrent() != ')') { + // TODO: Needs error handling. + fail("missing )") + } + p2 <- p2.forward() + } else { + { p2, matcher } <- parseSingleChar(p2) + } + } + } + + @type parseRange (ReadIterator) -> (ReadIterator,Int,Int) + parseRange (p) (p2,min,max) { + max <- 0 + { p2, min } <- parseCount(p) + if (p2.pastForwardEnd() || p2.readCurrent() != ',') { + max <- min + } else { + { p2, max } <- parseCount(p2.forward()) + } + } + + @type parseCount (ReadIterator) -> (ReadIterator,Int) + parseCount (p) (p2,count) { + // TODO: Needs error handling. + count <- 0 + p2 <- p + while (!p2.pastForwardEnd()) { + Char c <- p2.readCurrent() + if (c >= '0' && c <= '9') { + count <- 10*count + (c - '0') + } else { + break + } + } update { + p2 <- p2.forward() + } + } + + @type parseExpression (ReadIterator) -> + (ReadIterator,optional MatcherTemplate) + parseExpression (p) (p2,matcher) { + optional ReadSequence> choices <- empty + p2 <- p + while (!p2.pastForwardEnd()) { + { p2, optional ReadSequence> sequence } <- parseSequence(p2) + if (!present(sequence)) { + break + } + choices <- LinkedNode>$create( + MatchBranches$create(BranchSequence$create(sequence)),choices) + if (p2.pastForwardEnd() || p2.readCurrent() != '|') { + break + } + p2 <- p2.forward() + } + if (!present(choices)) { + matcher <- MatchEmpty$create() + } else { + matcher <- MatchChoices$create(choices) + } + } + + @type parseSingleChar (ReadIterator) -> + (ReadIterator,optional MatcherTemplate) + parseSingleChar (p) (p2,matcher) { + // TODO: Needs error handling. + Char c <- p.readCurrent() + p2 <- p.forward() + if (c == '\\') { + matcher <- MatchSingle$create(p2.readCurrent()) + p2 <- p.forward() + } elif (c == '.') { + matcher <- MatchAny$create() + } else { + matcher <- MatchSingle$create(c) + } + } + + @type parseCharChoices (ReadIterator) -> + (ReadIterator,optional MatcherTemplate) + parseCharChoices (p) (p2,matcher) { + p2 <- p + matcher <- empty + optional Char previous <- empty + Bool doRange <- false + optional ReadSequence> choices <- empty + while (!p2.pastForwardEnd()) { + Char c <- p2.readCurrent() + if (c == '\\') { + p2 <- p2.forward() + c <- p2.readCurrent() + } + if (c == ']') { + break + } elif (c == '-' && present(previous) && !doRange) { + doRange <- true + } elif (doRange) { + choices <- LinkedNode>$create(MatchRange$create(require(previous),c),choices) + previous <- empty + doRange <- false + } elif (present(previous)) { + choices <- LinkedNode>$create(MatchSingle$create(require(previous)),choices) + previous <- c + } else { + previous <- c + } + } update { + p2 <- p2.forward() + } + if (present(previous)) { + choices <- LinkedNode>$create(MatchSingle$create(require(previous)),choices) + } + matcher <- MatchChoices$create(choices) + } +} diff --git a/example/regex/regex-demo.0rx b/example/regex/regex-demo.0rx new file mode 100644 --- /dev/null +++ b/example/regex/regex-demo.0rx @@ -0,0 +1,92 @@ +concrete RegexDemo { + @type run () -> () +} + +define RegexDemo { + run () { + ~ testMatch("","",true) + ~ testMatch("","a",false) + ~ testMatch(".","a",true) + ~ testMatch(".","aa",false) + ~ testMatch("a",".",false) + ~ testMatch(".+","",false) + ~ testMatch(".+","a",true) + ~ testMatch(".+","ab",true) + ~ testMatch(".*.","a",true) + ~ testMatch(".*.","ab",true) + ~ testMatch("(ab)*","",true) + ~ testMatch("(ab)*","abab",true) + ~ testMatch("(ab)*","a",false) + ~ testMatch("(ab)*ac","abac",true) + ~ testMatch("(ab)*ac","ac",true) + ~ testMatch("(ab)*ac","aca",false) + ~ testMatch("(ab)*ac","acab",false) + ~ testMatch("(ab)*|ac","abab",true) + ~ testMatch("(ab)*|ac","ac",true) + ~ testMatch("(ab)*|ac","acac",false) + ~ testMatch("(ab)*|ac","abac",false) + ~ testMatch("a{2}","a",false) + ~ testMatch("a{2}","aa",true) + ~ testMatch("a{2}","aaa",false) + ~ testMatch("a{2,3}","a",false) + ~ testMatch("a{2,3}","aa",true) + ~ testMatch("a{2,3}","aaa",true) + ~ testMatch("a{2,3}","aaaa",false) + ~ testMatch("(a+){4}","aaa",false) + ~ testMatch("(a+){4}","aaaa",true) + ~ testMatch("(a+){4}","aaaaa",true) + ~ testMatch("(a+){4}","aaaaaa",true) + ~ testMatch("[a-z?]","q",true) + ~ testMatch("[a-z?]","-",false) + ~ testMatch("[a-z?]","?",true) + ~ testMatch("[a-z?]*","abcde?",true) + ~ testMatch("[a-z?]*","ab-cde",false) + + // A few malicious regexes from https://en.wikipedia.org/wiki/ReDoS. + // + // The first three below don't finish, due to repeat branching. The + // branching of "a+" is O(sqrt(2)^n) and "(a+)+" is therefore O(2^n). + // + // The first two could still be matched using non-branching repeats, since + // there is a complete overlap between the tail of one repeat and the next + // repeat, and repeats past 1 don't matter. The third could also be if the + // first 30 were expanded at the beginning. + // + // Overall, the safer solution would be to avoid repeat branching, and have + // a disclaimer about matching accuracy with repeated unbounded patterns + // that overlap themselves. + + // ~ testMatch("(a+)+","aaaaaaaaaaaaaaaaaaaaaaaa!",false) + // ~ testMatch("(a+)+","aaaaaaaaaaaaaaaaaaaaaaaa!",false) + // ~ testMatch("([a-zA-Z]+)*","aaaaaaaaaaaaaaaaaaaaaaaa!",false) + // ~ testMatch("(.*a){30}","aaaaaaaaaaaaaaaaaaaaaaaa!",false) + ~ testMatch("(a|aa)+","aaaaaaaaaaaaaaaaaaaaaaaa!",false) + + // This causes a ton of branching, but it actually finishes. Given m + // unbounded groups in a sequence, the branching is O(n^m). Since n^m + // increases rapidly with n, most sequence branches at any given time will + // not contain repeat branches within them. The exception is that each of + // the m groups will be in separate sequence branches from the beginning, + // *adding* O(sqrt(2)^n) branches. This means the overall complexity is + // O(n^m)+O(sqrt(2)^n): O(n^m) for smaller n, O(sqrt(2)^n) for larger n. + ~ testMatch("[ab]*[ac]*[ad]*[ae]*[af]*", + "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaad",true) + } + + @type testMatch (String,String,Bool) -> () + testMatch (pattern,data,expected) { + MatcherTemplate template <- require(CharRegex$parse(pattern)) + ~ LazyStream$new() + .append("Trying: regex=\"") + .append(pattern) + .append("\" data=\"") + .append(data) + .append("\" -> ") + .append(expected) + .append("...\n") + .writeTo(SimpleOutput$stderr()) + if (CharRegex$match(template,data) != expected) { + fail("Incorrect match result!") + } + } +} diff --git a/example/regex/regex-test.0rp b/example/regex/regex-test.0rp new file mode 100644 --- /dev/null +++ b/example/regex/regex-test.0rp @@ -0,0 +1,3 @@ +concrete RegexTest { + @type runTests () -> () +} diff --git a/example/regex/regex-test.0rt b/example/regex/regex-test.0rt new file mode 100644 --- /dev/null +++ b/example/regex/regex-test.0rt @@ -0,0 +1,1338 @@ +testcase "MatchSingle match" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "x" + MatcherTemplate template <- MatchSingle$create('x') + Matcher matcher <- template.newMatcher() + + if (template.matchesEmpty()) { + fail("matches empty") + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + MatchState state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchComplete())) { + fail(state) + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + // Should only match once. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + // Should match again after reset. + matcher <- template.newMatcher() + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchComplete())) { + fail(state) + } + } +} + + +testcase "MatchSingle non-match" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "x" + MatcherTemplate template <- MatchSingle$create('x') + Matcher matcher <- template.newMatcher() + + MatchState state <- matcher.tryNextMatch('y') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + + // Should keep failing to match. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + } +} + + +testcase "MatchRange match" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "[w-y]" + MatcherTemplate template <- MatchRange$create('w','y') + Matcher matcher <- template.newMatcher() + + if (template.matchesEmpty()) { + fail("matches empty") + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + MatchState state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchComplete())) { + fail(state) + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + // Should only match once. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + // Should match again after reset. + matcher <- template.newMatcher() + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchComplete())) { + fail(state) + } + } +} + + +testcase "MatchRange non-match" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "[w-y]" + MatcherTemplate template <- MatchRange$create('w','y') + Matcher matcher <- template.newMatcher() + + MatchState state <- matcher.tryNextMatch('a') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + + // Should keep failing to match. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + } +} + + +testcase "MatchAny" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "." + MatcherTemplate template <- MatchAny$create() + Matcher matcher <- template.newMatcher() + + if (template.matchesEmpty()) { + fail("matches empty") + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + MatchState state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchComplete())) { + fail(state) + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + // Should only match once. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + // Should match again after reset. + matcher <- template.newMatcher() + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchComplete())) { + fail(state) + } + } +} + + +testcase "MatchEmpty" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "" + MatcherTemplate template <- MatchEmpty$create() + Matcher matcher <- template.newMatcher() + + if (!template.matchesEmpty()) { + fail("doesn't match empty") + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + MatchState state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + // Should match again after reset. + matcher <- template.newMatcher() + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + } +} + + +testcase "MatchRepeat match" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "[w-y]{2,3}" + MatcherTemplate template <- + MatchRepeat$createRange(2,3,MatchRange$create('w','y')) + Matcher matcher <- template.newMatcher() + + if (template.matchesEmpty()) { + fail("matches empty") + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + MatchState state <- MatchState$matchFail() + + // First character. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + // Second character. + state <- matcher.tryNextMatch('y') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + // Third character. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchComplete())) { + fail(state) + } + + // Fourth character. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + // Reset to reuse the matcher. + matcher <- template.newMatcher() + + // Fourth character. + state <- matcher.tryNextMatch('w') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + // Fifth character. + state <- matcher.tryNextMatch('w') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + } +} + + +testcase "MatchRepeat nested" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "(x*){2,}" + MatcherTemplate template <- + MatchRepeat$createRange(2,0, + MatchRepeat$createZeroPlus(MatchSingle$create('x'))) + Matcher matcher <- template.newMatcher() + + if (!template.matchesEmpty()) { + fail("doesn't match empty") + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + MatchState state <- MatchState$matchFail() + + // First character. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + // Second character. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + // Third character. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + } +} + + +testcase "MatchRepeat non-match" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "[w-y]{2,3}" + MatcherTemplate template <- + MatchRepeat$createRange(2,3,MatchRange$create('w','y')) + Matcher matcher <- template.newMatcher() + + MatchState state <- MatchState$matchFail() + + // First character. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + // Second character. + state <- matcher.tryNextMatch('q') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + // Should keep failing to match. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + } +} + + +testcase "MatchRepeat optional suffix" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "(ab*)*" + MatcherTemplate template <- + MatchRepeat$createZeroPlus( + MatchBranches$create( + BranchSequence$create( + LinkedNode>$create(MatchSingle$create('a'), + LinkedNode>$create( + MatchRepeat$createZeroPlus(MatchSingle$create('b')),empty))))) + Matcher matcher <- template.newMatcher() + + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + MatchState state <- MatchState$matchFail() + + // First character. + state <- matcher.tryNextMatch('a') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + // Second character. + state <- matcher.tryNextMatch('b') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + // Third character. + state <- matcher.tryNextMatch('a') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + } +} + + +testcase "MatchChoices match" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "[w-y]|a*" + MatcherTemplate template <- + MatchChoices$create( + LinkedNode>$create(MatchRange$create('w','y'), + LinkedNode>$create( + MatchBranches$create( + BranchRepeat$createZeroPlus(MatchSingle$create('a'))),empty))) + Matcher matcher <- template.newMatcher() + + MatchState state <- MatchState$matchFail() + + if (!template.matchesEmpty()) { + fail("doesn't match empty") + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + // First character. + state <- matcher.tryNextMatch('a') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + + // Second character. + state <- matcher.tryNextMatch('a') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + + // Third character. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + + // Reset to reuse the matcher. + matcher <- template.newMatcher() + + // First character. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchComplete())) { + fail(state) + } + } +} + + +testcase "MatchChoices non-match" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "[w-y]|a*" + MatcherTemplate template <- + MatchChoices$create( + LinkedNode>$create(MatchRange$create('w','y'), + LinkedNode>$create( + MatchBranches$create( + BranchRepeat$createZeroPlus(MatchSingle$create('a'))),empty))) + Matcher matcher <- template.newMatcher() + + if (!template.matchesEmpty()) { + fail("doesn't match empty") + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + MatchState state <- MatchState$matchFail() + + // First character. + state <- matcher.tryNextMatch('a') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + + // Should keep failing to match. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + } +} + + +testcase "MatchChoices empty choice" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "[w-y]|a{2,2}|" + MatcherTemplate template <- + MatchChoices$create( + LinkedNode>$create(MatchRange$create('w','y'), + LinkedNode>$create( + MatchBranches$create( + BranchRepeat$createRange(2,2,MatchSingle$create('a'))), + LinkedNode>$create( + MatchEmpty$create(),empty)))) + Matcher matcher <- template.newMatcher() + + if (!template.matchesEmpty()) { + fail("doesn't match empty") + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + MatchState state <- MatchState$matchFail() + + // First character. + state <- matcher.tryNextMatch('a') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + } +} + + +testcase "BranchRepeat match" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "[w-y]{2,3}" + MatchBrancherTemplate template <- + BranchRepeat$createRange(2,3,MatchRange$create('w','y')) + MatchBrancher brancher <- template.newBrancher() + + if (template.matchesEmpty()) { + fail("matches empty") + } + if (brancher.matchSatisfied()) { + fail("match satisfied") + } + + MatchState state <- MatchState$matchFail() + optional ReadSequence> branches <- empty + + // First character. + { state, branches } <- brancher.tryBranches('x') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!present(branches)) { + fail("branch missing") + } + + brancher <- require(branches).value() + if (brancher.matchSatisfied()) { + fail("match satisfied") + } + branches <- require(branches).next() + if (present(branches)) { + fail("branch present") + } + + // Second character. + { state, branches } <- brancher.tryBranches('y') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!present(branches)) { + fail("branch missing") + } + if (!brancher.matchSatisfied()) { + fail("match not satisfied") + } + + brancher <- require(branches).value() + branches <- require(branches).next() + if (present(branches)) { + fail("branch present") + } + + // Third character. + { state, branches } <- brancher.tryBranches('x') + if (!(state `MatchState$equals` MatchState$matchComplete())) { + fail(state) + } + if (present(branches)) { + fail("branch present") + } + + // Reset to reuse the brancher. + brancher <- template.newBrancher() + + // Fourth character. + { state, branches } <- brancher.tryBranches('w') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!present(branches)) { + fail("branch missing") + } + } +} + + +testcase "BranchRepeat nested" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "(x*){2,}" + MatchBrancherTemplate template <- + BranchRepeat$createRange(2,0, + MatchBranches$create( + BranchRepeat$createZeroPlus(MatchSingle$create('x')))) + MatchBrancher brancher <- template.newBrancher() + + if (!template.matchesEmpty()) { + fail("doesn't match empty") + } + if (!brancher.matchSatisfied()) { + fail("match not satisfied") + } + + MatchState state <- MatchState$matchFail() + optional ReadSequence> branches <- empty + + // First character. + { state, branches } <- brancher.tryBranches('x') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!present(branches)) { + fail("branch missing") + } + + brancher <- require(branches).value() + if (!brancher.matchSatisfied()) { + fail("match not satisfied") + } + branches <- require(branches).next() + if (present(branches)) { + fail("branch present") + } + + // Second character. + { state, branches } <- brancher.tryBranches('x') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!present(branches)) { + fail("branch missing") + } + + brancher <- require(branches).value() + if (!brancher.matchSatisfied()) { + fail("match not satisfied") + } + // Expect one additional branch to continue "xx*". + branches <- require(branches).next() + if (!present(branches)) { + fail("branch missing") + } + + // Third character, branch 1. + { state, _ } <- brancher.tryBranches('x') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + + brancher <- require(branches).value() + if (!brancher.matchSatisfied()) { + fail("match not satisfied") + } + // No more branches expected. + branches <- require(branches).next() + if (present(branches)) { + fail("branch present") + } + + // Third character, branch 2. + { state, _ } <- brancher.tryBranches('x') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + } +} + + +testcase "BranchRepeat non-match" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "[w-y]{2,3}" + MatchBrancherTemplate template <- + BranchRepeat$createRange(2,3,MatchRange$create('w','y')) + MatchBrancher brancher <- template.newBrancher() + + MatchState state <- MatchState$matchFail() + optional ReadSequence> branches <- empty + + // First character. + { state, branches } <- brancher.tryBranches('x') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!present(branches)) { + fail("branch missing") + } + + brancher <- require(branches).value() + if (brancher.matchSatisfied()) { + fail("match satisfied") + } + branches <- require(branches).next() + if (present(branches)) { + fail("branch present") + } + + // Second character. + { state, branches } <- brancher.tryBranches('q') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + if (present(branches)) { + fail("branch present") + } + } +} + + +testcase "BranchSequence match" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "[w-y]a" + MatchBrancherTemplate template <- + BranchSequence$create( + LinkedNode>$create(MatchRange$create('w','y'), + LinkedNode>$create(MatchSingle$create('a'),empty))) + MatchBrancher brancher <- template.newBrancher() + + if (template.matchesEmpty()) { + fail("matches empty") + } + if (brancher.matchSatisfied()) { + fail("match satisfied") + } + + MatchState state <- MatchState$matchFail() + optional ReadSequence> branches <- empty + + // First character. + { state, branches } <- brancher.tryBranches('x') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!present(branches)) { + fail("branch missing") + } + + brancher <- require(branches).value() + branches <- require(branches).next() + if (present(branches)) { + fail("branch present") + } + + // Second character. + { state, branches } <- brancher.tryBranches('a') + if (!(state `MatchState$equals` MatchState$matchComplete())) { + fail(state) + } + if (!present(branches)) { + fail("branch missing") + } + + // The final branch should just be a record of completeness. + if (!require(branches).value().matchSatisfied()) { + fail("match not satisfied") + } + { state, branches } <- require(branches).value().tryBranches('a') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + + // Reset to reuse the brancher. + brancher <- template.newBrancher() + + // Third character. + { state, branches } <- brancher.tryBranches('y') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!present(branches)) { + fail("branch missing") + } + } +} + + +testcase "BranchSequence non-match" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "[w-y]a" + MatchBrancherTemplate template <- + BranchSequence$create( + LinkedNode>$create(MatchRange$create('w','y'), + LinkedNode>$create(MatchSingle$create('a'),empty))) + MatchBrancher brancher <- template.newBrancher() + + MatchState state <- MatchState$matchFail() + optional ReadSequence> branches <- empty + + // First character. + { state, branches } <- brancher.tryBranches('q') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + if (present(branches)) { + fail("branch present") + } + + // Should keep failing to match. + { state, branches } <- brancher.tryBranches('x') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + } +} + + +testcase "BranchSequence skip empty failed" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "a*b" + MatchBrancherTemplate template <- + BranchSequence$create( + LinkedNode>$create( + MatchBranches$create( + BranchRepeat$createZeroPlus(MatchSingle$create('a'))), + LinkedNode>$create( + MatchSingle$create('b'),empty))) + MatchBrancher brancher <- template.newBrancher() + + if (template.matchesEmpty()) { + fail("matches empty") + } + if (brancher.matchSatisfied()) { + fail("match satisfied") + } + + MatchState state <- MatchState$matchFail() + optional ReadSequence> branches <- empty + + // First character. + { state, branches } <- brancher.tryBranches('b') + if (!(state `MatchState$equals` MatchState$matchComplete())) { + fail(state) + } + if (!present(branches)) { + fail("branch missing") + } + } +} + + +testcase "BranchSequence fail non-empty field" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "a+b" + MatchBrancherTemplate template <- + BranchSequence$create( + LinkedNode>$create( + MatchBranches$create( + BranchRepeat$createOnePlus(MatchSingle$create('a'))), + LinkedNode>$create( + MatchSingle$create('b'),empty))) + MatchBrancher brancher <- template.newBrancher() + + if (template.matchesEmpty()) { + fail("matches empty") + } + if (brancher.matchSatisfied()) { + fail("match satisfied") + } + + MatchState state <- MatchState$matchFail() + optional ReadSequence> branches <- empty + + // First character. + { state, branches } <- brancher.tryBranches('b') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + if (present(branches)) { + fail("branch present") + } + } +} + + +testcase "BranchSequence branch sequence multi-match" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "a*a{0,2}" + MatchBrancherTemplate template <- + BranchSequence$create( + LinkedNode>$create( + MatchBranches$create( + BranchRepeat$createZeroPlus(MatchSingle$create('a'))), + LinkedNode>$create( + MatchBranches$create( + BranchRepeat$createRange(0,2,MatchSingle$create('a'))),empty))) + MatchBrancher brancher <- template.newBrancher() + + if (!template.matchesEmpty()) { + fail("doesn't match empty") + } + if (!brancher.matchSatisfied()) { + fail("match not satisfied") + } + + MatchState state <- MatchState$matchFail() + optional ReadSequence> branches <- empty + + // First character. + { state, branches } <- brancher.tryBranches('a') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!present(branches)) { + fail("branch missing") + } + + brancher <- require(branches).value() + branches <- require(branches).next() + if (!present(branches)) { + fail("branch missing") + } + + // TODO: This assumes that the branches are ordered from longest to shortest + // remaining sequence. + + // Second character, branch 1. + { state, _ } <- brancher.tryBranches('a') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + + brancher <- require(branches).value() + branches <- require(branches).next() + if (present(branches)) { + fail("branch present") + } + + // Second character, branch 2. + { state, _ } <- brancher.tryBranches('a') + if (!(state `MatchState$equals` MatchState$matchComplete())) { + fail(state) + } + } +} + + +testcase "MatchBranches match" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "[w-y]a" + MatcherTemplate template <- + MatchBranches$create( + BranchSequence$create( + LinkedNode>$create(MatchRange$create('w','y'), + LinkedNode>$create(MatchSingle$create('a'),empty)))) + Matcher matcher <- template.newMatcher() + + if (template.matchesEmpty()) { + fail("matches empty") + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + MatchState state <- MatchState$matchFail() + + // First character. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + // Second character. + state <- matcher.tryNextMatch('a') + if (!(state `MatchState$equals` MatchState$matchComplete())) { + fail(state) + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + // Reset to reuse the matcher. + matcher <- template.newMatcher() + + // Third character. + state <- matcher.tryNextMatch('y') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + } +} + + +testcase "MatchBranches non-match" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "[w-y]a" + MatcherTemplate template <- + MatchBranches$create( + BranchSequence$create( + LinkedNode>$create(MatchRange$create('w','y'), + LinkedNode>$create(MatchSingle$create('a'),empty)))) + Matcher matcher <- template.newMatcher() + + if (template.matchesEmpty()) { + fail("matches empty") + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + MatchState state <- MatchState$matchFail() + + // First character. + state <- matcher.tryNextMatch('x') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + // Second character. + state <- matcher.tryNextMatch('q') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + // Should keep failing to match. + state <- matcher.tryNextMatch('y') + if (!(state `MatchState$equals` MatchState$matchFail())) { + fail(state) + } + } +} + + +testcase "MatchBranches branched match" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "ab" + MatcherTemplate templateAB <- + MatchBranches$create( + BranchSequence$create( + LinkedNode>$create(MatchSingle$create('a'), + LinkedNode>$create(MatchSingle$create('b'),empty)))) + // Pattern: "ac" + MatcherTemplate templateAC <- + MatchBranches$create( + BranchSequence$create( + LinkedNode>$create(MatchSingle$create('a'), + LinkedNode>$create(MatchSingle$create('c'),empty)))) + // Pattern: "(ab)*ac" + MatcherTemplate template <- + MatchBranches$create( + BranchSequence$create( + LinkedNode>$create( + MatchBranches$create( + BranchRepeat$createZeroPlus(templateAB)), + LinkedNode>$create(templateAC,empty)))) + Matcher matcher <- template.newMatcher() + + MatchState state <- MatchState$matchFail() + + // First character. + state <- matcher.tryNextMatch('a') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + // Second character. + state <- matcher.tryNextMatch('c') + if (!(state `MatchState$equals` MatchState$matchComplete())) { + fail(state) + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + // Reset to reuse the matcher. + matcher <- template.newMatcher() + + // First character. + state <- matcher.tryNextMatch('a') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + // Second character. + state <- matcher.tryNextMatch('b') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + } +} + + +testcase "MatchBranches partial repeat" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Pattern: "(ab)*" + MatcherTemplate template <- + MatchBranches$create( + BranchRepeat$createZeroPlus( + MatchBranches$create( + BranchSequence$create( + LinkedNode>$create(MatchSingle$create('a'), + LinkedNode>$create(MatchSingle$create('b'),empty)))))) + Matcher matcher <- template.newMatcher() + + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + + MatchState state <- MatchState$matchFail() + + // First character. + state <- matcher.tryNextMatch('a') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (matcher.matchSatisfied()) { + fail("match satisfied") + } + + // Second character. + state <- matcher.tryNextMatch('b') + if (!(state `MatchState$equals` MatchState$matchContinue())) { + fail(state) + } + if (!matcher.matchSatisfied()) { + fail("match not satisfied") + } + } +} diff --git a/example/regex/regex.0rp b/example/regex/regex.0rp new file mode 100644 --- /dev/null +++ b/example/regex/regex.0rp @@ -0,0 +1,127 @@ +concrete MatchState { + refines Formatted + defines Equals + defines LessThan + + // Ordered from low to high. + + @type matchFail () -> (MatchState) // Matching has failed. + @type matchComplete () -> (MatchState) // End of the pattern. + @type matchContinue () -> (MatchState) // Matching must continue. +} + +@value interface Matcher<#c|> { + // Returns true if the pattern is complete without additional data. + matchSatisfied () -> (Bool) + + // This can be called as long as it returns matchContinue(). The matcher does + // not branch; each call updates it with the next data point in the input. + // + // Returns: + // - matchFail(): The pattern cannot be completed. + // - matchContinue(): Matching can continue; check matchSatisfied() to see if + // more data is required to complete the pattern. + // - matchComplete(): The pattern has been completed and cannot match any + // additional data. + tryNextMatch (#c) -> (MatchState) +} + +@value interface MatcherTemplate<#c|> { + // Returns true if the pattern can match an empty sequence. + matchesEmpty () -> (Bool) + newMatcher () -> (Matcher<#c>) +} + +@value interface MatchBrancher<#c|> { + // Returns true if the pattern is complete without additional data. + matchSatisfied () -> (Bool) + + // NOTE: Calling this invalidates the MatchBrancher. Subsequent calls should + // be done against the returned branches. + // Returns: + // - state: The highest state of the branches checked. + // - branches: All branches with a status of matchContinue(). + tryBranches (#c) -> (MatchState /*state*/, + optional ReadSequence> /*branches*/) +} + +@value interface MatchBrancherTemplate<#c|> { + // Returns true if the pattern can match an empty sequence. + matchesEmpty () -> (Bool) + newBrancher () -> (MatchBrancher<#c>) +} + +concrete MatchSingle<#c> { + #c defines Equals<#c> + + refines MatcherTemplate<#c> + + @type create (#c) -> (MatchSingle<#c>) +} + +concrete MatchRange<#c> { + #c defines LessThan<#c> + + refines MatcherTemplate<#c> + + @type create (#c,#c) -> (MatchRange<#c>) +} + +concrete MatchAny { + refines MatcherTemplate + + @type create () -> (MatchAny) +} + +concrete MatchEmpty { + refines MatcherTemplate + + @type create () -> (MatchEmpty) +} + +concrete MatchRepeat<#c> { + refines MatcherTemplate<#c> + + @type createZeroPlus (MatcherTemplate<#c>) -> (MatchRepeat<#c>) + @type createOnePlus (MatcherTemplate<#c>) -> (MatchRepeat<#c>) + @type createRange (Int,Int,MatcherTemplate<#c>) -> (MatchRepeat<#c>) +} + +concrete MatchChoices<#c> { + refines MatcherTemplate<#c> + + @type create (optional ReadSequence>) -> (MatchChoices<#c>) +} + +concrete MatchBranches<#c> { + refines MatcherTemplate<#c> + + @type create (MatchBrancherTemplate<#c>) -> (MatcherTemplate<#c>) +} + +concrete BranchRepeat<#c> { + refines MatchBrancherTemplate<#c> + + @type createZeroPlus (MatcherTemplate<#c>) -> (BranchRepeat<#c>) + @type createOnePlus (MatcherTemplate<#c>) -> (BranchRepeat<#c>) + @type createRange (Int,Int,MatcherTemplate<#c>) -> (BranchRepeat<#c>) +} + +concrete BranchSequence<#c> { + refines MatchBrancherTemplate<#c> + + @type create (optional ReadSequence>) -> (BranchSequence<#c>) +} + +@value interface ReadSequence<|#c> { + value () -> (#c) + next () -> (optional ReadSequence<#c>) +} + +concrete LinkedNode<#x> { + refines ReadSequence<#x> + + @type create (#x,optional ReadSequence<#x>) -> (ReadSequence<#x>) + @type concatSequences (optional ReadSequence<#x>,optional ReadSequence<#x>) -> + (optional ReadSequence<#x>) +} diff --git a/example/regex/regex.0rx b/example/regex/regex.0rx new file mode 100644 --- /dev/null +++ b/example/regex/regex.0rx @@ -0,0 +1,724 @@ +define MatchState { + @value Int enum + @value String name + @category MatchState matchFailVal <- MatchState{ 0, "matchFail" } + @category MatchState matchCompleteVal <- MatchState{ 1, "matchComplete" } + @category MatchState matchContinueVal <- MatchState{ 2, "matchContinue" } + + formatted () { + return "MatchState$" + name + "()" + } + + equals (x,y) { + return x.getEnum() == y.getEnum() + } + + lessThan (x,y) { + return x.getEnum() < y.getEnum() + } + + matchFail () { + return matchFailVal + } + + matchComplete () { + return matchCompleteVal + } + + matchContinue () { + return matchContinueVal + } + + @value getEnum () -> (Int) + getEnum () { + return enum + } +} + +define MatchSingle { + @value #c match + + create (match) { + return MatchSingle<#c>{ match } + } + + matchesEmpty () { + return false + } + + newMatcher () { + return MatchSingleMatcher<#c>$create(match) + } +} + +concrete MatchSingleMatcher<#c> { + #c defines Equals<#c> + + refines Matcher<#c> + + @type create (#c) -> (MatchSingleMatcher<#c>) +} + +define MatchSingleMatcher { + @value #c match + @value MatchState state + + create (match) { + return MatchSingleMatcher<#c>{ match, MatchState$matchContinue() } + } + + matchSatisfied () { + return state `MatchState$equals` MatchState$matchComplete() + } + + tryNextMatch (data) { + if (!(state `MatchState$equals` MatchState$matchContinue())) { + return (state <- MatchState$matchFail()) + } + if (data `#c$equals` match) { + return (state <- MatchState$matchComplete()) + } else { + return (state <- MatchState$matchFail()) + } + } +} + +define MatchRange { + @value #c minMatch + @value #c maxMatch + + create (minMatch,maxMatch) { + return MatchRange<#c>{ minMatch, maxMatch } + } + + matchesEmpty () { + return false + } + + newMatcher () { + return MatchRangeMatcher<#c>$create(minMatch,maxMatch) + } +} + +concrete MatchRangeMatcher<#c> { + #c defines LessThan<#c> + + refines Matcher<#c> + + @type create (#c,#c) -> (MatchRangeMatcher<#c>) +} + +define MatchRangeMatcher { + @value #c minMatch + @value #c maxMatch + @value MatchState state + + create (minMatch,maxMatch) { + return MatchRangeMatcher<#c>{ minMatch, maxMatch, MatchState$matchContinue() } + } + + matchSatisfied () { + return state `MatchState$equals` MatchState$matchComplete() + } + + tryNextMatch (data) { + if (!(state `MatchState$equals` MatchState$matchContinue())) { + return (state <- MatchState$matchFail()) + } + if (!(data `#c$lessThan` minMatch) && !(maxMatch `#c$lessThan` data)) { + return (state <- MatchState$matchComplete()) + } else { + return (state <- MatchState$matchFail()) + } + } +} + +define MatchAny { + create () { + return MatchAny{ } + } + + matchesEmpty () { + return false + } + + newMatcher () { + return MatchAnyMatcher$create() + } +} + +concrete MatchAnyMatcher { + refines Matcher + + @type create () -> (MatchAnyMatcher) +} + +define MatchAnyMatcher { + @value MatchState state + + create () { + return MatchAnyMatcher{ MatchState$matchContinue() } + } + + matchSatisfied () { + return state `MatchState$equals` MatchState$matchComplete() + } + + tryNextMatch (data) { + if (!(state `MatchState$equals` MatchState$matchContinue())) { + return (state <- MatchState$matchFail()) + } + return (state <- MatchState$matchComplete()) + } +} + +define MatchEmpty { + create () { + return MatchEmpty{ } + } + + matchesEmpty () { + return true + } + + newMatcher () { + return MatchEmptyMatcher$create() + } +} + +concrete MatchEmptyMatcher { + refines Matcher + + @type create () -> (MatchEmptyMatcher) +} + +define MatchEmptyMatcher { + @value Bool failed + + create () { + return MatchEmptyMatcher{ false } + } + + matchSatisfied () { + return !failed + } + + tryNextMatch (data) { + failed <- true + return MatchState$matchFail() + } +} + +define MatchRepeat { + @value MatcherTemplate<#c> template + @value Int minCount + @value Int maxCount + + createZeroPlus (template) { + return createRange(0,0,template) + } + + createOnePlus (template) { + return createRange(1,0,template) + } + + createRange (minCount,maxCount,template) { + return MatchRepeat<#c>{ template, minCount, maxCount } + } + + matchesEmpty () { + return minCount <= 0 || template.matchesEmpty() + } + + newMatcher () { + return MatchRepeatMatcher<#c>$create(minCount,maxCount,template) + } +} + +concrete MatchRepeatMatcher<#c> { + refines Matcher<#c> + + @type create (Int,Int,MatcherTemplate<#c>) -> (MatchRepeatMatcher<#c>) +} + +define MatchRepeatMatcher { + @value MatcherTemplate<#c> template + @value Matcher<#c> matcher + @value Int minCount + @value Int maxCount // 0 means unlimited. + @value Int repetitionCount + @value MatchState lastState + + create (minCount,maxCount,template) { + return MatchRepeatMatcher<#c>{ template, template.newMatcher(), minCount, + maxCount, 0, MatchState$matchComplete() } + } + + matchSatisfied () { + if (lastState `MatchState$equals` MatchState$matchFail()) { + return false + } + if (lastState `MatchState$equals` MatchState$matchContinue() && + (repetitionCount+1 >= minCount || template.matchesEmpty()) && + matcher.matchSatisfied()) { + // The rest of the current repetition can be ignored. + return true + } + if (lastState `MatchState$equals` MatchState$matchComplete() && + (repetitionCount >= minCount || template.matchesEmpty())) { + return true + } + return false + } + + tryNextMatch (data) (state) { + if (atMax() || lastState `MatchState$equals` MatchState$matchFail()) { + return MatchState$matchFail() + } + Bool canSkip <- matcher.matchSatisfied() + state <- matcher.tryNextMatch(data) + if (state `MatchState$equals` MatchState$matchFail() && + lastState `MatchState$equals` MatchState$matchContinue() && canSkip) { + // Handle the case where an optional end to the pattern can be skipped. + ~ incrementMatch() + ~ startRepeat() + state <- matcher.tryNextMatch(data) + } + lastState <- state + if (state `MatchState$equals` MatchState$matchComplete()) { + ~ incrementMatch() + ~ startRepeat() + if (atMax()) { + state <- MatchState$matchComplete() + } else { + state <- MatchState$matchContinue() + } + } + } + + @value incrementMatch () -> () + incrementMatch () { + repetitionCount <- repetitionCount+1 + } + + @value atMax () -> (Bool) + atMax () { + return maxCount > 0 && repetitionCount >= maxCount + } + + @value startRepeat () -> () + startRepeat () { + matcher <- template.newMatcher() + } +} + +define MatchChoices { + @value optional ReadSequence> choices + + create (choices) { + return MatchChoices<#c>{ choices } + } + + matchesEmpty () { + scoped { + optional ReadSequence> current <- choices + } in while (present(current)) { + if (require(current).value().matchesEmpty()) { + return true + } + } update { + current <- require(current).next() + } + return false + } + + newMatcher () { + return MatchChoicesMatcher<#c>$create(recursiveNewMatcher(choices)) + } + + @type recursiveNewMatcher (optional ReadSequence>) -> + (optional ReadSequence>) + recursiveNewMatcher (choices) { + if (!present(choices)) { + return empty + } + return LinkedNode>$create(require(choices).value().newMatcher(), + recursiveNewMatcher(require(choices).next())) + } +} + +concrete MatchChoicesMatcher<#c> { + refines Matcher<#c> + + @type create (optional ReadSequence>) -> (MatchChoicesMatcher<#c>) +} + +define MatchChoicesMatcher { + @value optional ReadSequence> choices + + create (choices) { + return MatchChoicesMatcher<#c>{ choices } + } + + matchSatisfied () { + scoped { + optional ReadSequence> current <- choices + } in while (present(current)) { + if (require(current).value().matchSatisfied()) { + return true + } + } update { + current <- require(current).next() + } + return false + } + + tryNextMatch (data) (state) { + state <- MatchState$matchFail() + scoped { + optional ReadSequence> current <- choices + } in while (present(current)) { + // NOTE: Failing matchers are left in for simplicity, under the assumption + // that they will keep failing. + MatchState state2 <- require(current).value().tryNextMatch(data) + if (state `MatchState$lessThan` state2) { + state <- state2 + } + } update { + current <- require(current).next() + } + } +} + +define MatchBranches { + @value MatchBrancherTemplate<#c> template + + create (template) { + return MatchBranches<#c>{ template } + } + + matchesEmpty () { + return template.matchesEmpty() + } + + newMatcher () { + return MatchBranchesMatcher<#c>$create(template.newBrancher()) + } +} + +concrete MatchBranchesMatcher<#c> { + refines Matcher<#c> + + @type create (MatchBrancher<#c>) -> (MatchBranchesMatcher<#c>) +} + +define MatchBranchesMatcher { + @value optional ReadSequence> branches + @value Bool complete + + create (brancher) { + return MatchBranchesMatcher<#c>{ LinkedNode>$create(brancher,empty), false } + } + + matchSatisfied () { + if (complete) { + return true + } + scoped { + optional ReadSequence> current <- branches + } in while (present(current)) { + if (require(current).value().matchSatisfied()) { + return true + } + } update { + current <- require(current).next() + } + return false + } + + tryNextMatch (data) (state) { + state <- MatchState$matchFail() + optional ReadSequence> current <- branches + branches <- empty + complete <- false + scoped { + } in while(present(current)) { + { MatchState state2, optional ReadSequence> branches2 } <- + require(current).value().tryBranches(data) + if (state2 `MatchState$equals` MatchState$matchComplete()) { + complete <- true + } + if (state `MatchState$lessThan` state2) { + state <- state2 + } + branches <- LinkedNode>$concatSequences(branches2,branches) + } update { + current <- require(current).next() + } + } +} + +concrete BranchRepeatMatcher<#c> { + refines MatchBrancher<#c> + + @type create (Int,Int,MatcherTemplate<#c>) -> (BranchRepeatMatcher<#c>) + @value tryBranches (#c) -> (MatchState,optional ReadSequence>) +} + +define BranchRepeatMatcher { + @value MatcherTemplate<#c> template + @value Matcher<#c> matcher + @value Int minCount + @value Int maxCount // 0 means unlimited. + @value Int repetitionCount + @value MatchState lastState + + create (minCount,maxCount,template) { + return BranchRepeatMatcher<#c>{ template, template.newMatcher(), minCount, + maxCount, 0, MatchState$matchComplete() } + } + + matchSatisfied () { + if (lastState `MatchState$equals` MatchState$matchFail()) { + return false + } + if (lastState `MatchState$equals` MatchState$matchContinue() && + (repetitionCount+1 >= minCount || template.matchesEmpty()) && + matcher.matchSatisfied()) { + // The rest of the current repetition can be ignored. + return true + } + if (lastState `MatchState$equals` MatchState$matchComplete() && + (repetitionCount >= minCount || template.matchesEmpty())) { + return true + } + return false + } + + tryBranches (data) (state,branch) { + state <- MatchState$matchFail() + branch <- empty + if (atMax() || lastState `MatchState$equals` MatchState$matchFail()) { + return _ + } + if (lastState `MatchState$equals` MatchState$matchContinue()) { + // Handle a possible single branch. + Bool canSkip <- matcher.matchSatisfied() + state <- matcher.tryNextMatch(data) + if (canSkip) { + if (state `MatchState$equals` MatchState$matchContinue()) { + // Add a branch for the optional suffix. + branch <- LinkedNode>$create( + BranchRepeatMatcher<#c>{ template, matcher, minCount, + maxCount, repetitionCount, + MatchState$matchContinue() },empty) + } + // Continue, skipping over the optional suffix. + ~ incrementMatch() + ~ startRepeat() + if (atMax()) { + // Skipping the branch puts us at the max. + return _ + } + state <- matcher.tryNextMatch(data) + } + } else { + // Branching is not possible. + state <- matcher.tryNextMatch(data) + } + lastState <- state + if (state `MatchState$equals` MatchState$matchComplete()) { + ~ incrementMatch() + ~ startRepeat() + if (!atMax()) { + branch <- LinkedNode>$create(self,branch) + } + } elif (state `MatchState$equals` MatchState$matchContinue()) { + branch <- LinkedNode>$create(self,branch) + } + if (present(branch)) { + state <- MatchState$matchContinue() + } + } + + @value incrementMatch () -> () + incrementMatch () { + repetitionCount <- repetitionCount+1 + } + + @value atMax () -> (Bool) + atMax () { + return maxCount > 0 && repetitionCount >= maxCount + } + + @value startRepeat () -> () + startRepeat () { + matcher <- template.newMatcher() + } +} + +define BranchSequence { + @value optional ReadSequence> sequence + + create (sequence) { + return BranchSequence<#c>{ sequence } + } + + matchesEmpty () { + scoped { + optional ReadSequence> current <- sequence + } in while (present(current)) { + if (!require(current).value().matchesEmpty()) { + return false + } + } update { + current <- require(current).next() + } + return true + } + + newBrancher () { + return BranchSequenceMatcher<#c>$create(sequence) + } +} + +concrete BranchSequenceMatcher<#c> { + refines MatchBrancher<#c> + + @type create (optional ReadSequence>) -> (BranchSequenceMatcher<#c>) + @value tryBranches (#c) -> (MatchState,optional ReadSequence>) +} + +define BranchSequenceMatcher { + @value optional Matcher<#c> continued + @value optional ReadSequence> sequence + @value Bool consumed + + create (sequence) { + return BranchSequenceMatcher<#c>{ empty, sequence, false } + } + + matchSatisfied () { + if (consumed) { + return false + } + if (present(continued) && !require(continued).matchSatisfied()) { + return false + } + scoped { + optional ReadSequence> current <- sequence + } in while (present(current)) { + if (!require(current).value().matchesEmpty()) { + return false + } + } update { + current <- require(current).next() + } + return true + } + + tryBranches (data) { + if (consumed) { + return { MatchState$matchFail(), empty } + } + consumed <- true + return recursiveBranch(data,continued,sequence) + } + + @type recursiveBranch (#c,optional Matcher<#c>,optional ReadSequence>) -> + (MatchState,optional ReadSequence>) + recursiveBranch (data,continued,sequence) (state,branch) { + state <- MatchState$matchFail() + branch <- empty + if (!present(continued) && !present(sequence)) { + return _ + } + optional Matcher<#c> continued2 <- continued + optional ReadSequence> sequence2 <- sequence + if (!present(continued2)) { + continued2 <- require(sequence2).value().newMatcher() + sequence2 <- require(sequence2).next() + } + if (require(continued2).matchSatisfied()) { + { MatchState state2, branch } <- recursiveBranch(data,empty,sequence2) + if (state `MatchState$lessThan` state2) { + state <- state2 + } + } + MatchState state2 <- require(continued2).tryNextMatch(data) + if (state `MatchState$lessThan` state2) { + state <- state2 + } + if (state2 `MatchState$equals` MatchState$matchComplete()) { + if (present(sequence2)) { + // Add a branch to continue this sequence. + branch <- LinkedNode>$create( + BranchSequenceMatcher<#c>{ empty, sequence2, false },branch) + state <- MatchState$matchContinue() + } else { + // Add a branch to serve as a record of completeness. It will fail to + // match anything, but matchSatisfied() will return true. + branch <- LinkedNode>$create( + BranchSequenceMatcher<#c>{ empty, empty, false },branch) + } + } elif (state `MatchState$equals` MatchState$matchContinue()) { + // Add a branch to continue this sequence. + branch <- LinkedNode>$create( + BranchSequenceMatcher<#c>{ continued2, sequence2, false },branch) + } + } +} + +define BranchRepeat { + @value MatcherTemplate<#c> template + @value Int minCount + @value Int maxCount + + createZeroPlus (template) { + return createRange(0,0,template) + } + + createOnePlus (template) { + return createRange(1,0,template) + } + + createRange (minCount,maxCount,template) { + return BranchRepeat<#c>{ template, minCount, maxCount } + } + + matchesEmpty () { + return minCount <= 0 || template.matchesEmpty() + } + + newBrancher () { + return BranchRepeatMatcher<#c>$create(minCount,maxCount,template) + } +} + +define LinkedNode { + @value optional ReadSequence<#x> nextNode + @value #x data + + create (data,nextNode) { + return LinkedNode<#x>{ nextNode, data } + } + + concatSequences (head1,head2) { + if (!present(head2)) { + return head1 + } elif (present(head1)) { + return LinkedNode<#x>$create(require(head1).value(), + concatSequences(require(head1).next(),head2)) + } else { + return head2 + } + } + + value () { + return data + } + + next () { + return nextNode + } +} diff --git a/example/tree/README.md b/example/tree/README.md new file mode 100644 --- /dev/null +++ b/example/tree/README.md @@ -0,0 +1,20 @@ +# Zeolite Tree Example + +*Also see +[a highlighted version of the example code](https://ta0kira.github.io/zeolite/example/tree/index.html).* + +To run the example: + +```shell +# This is just to locate the example code. Not for normal use! +ZEOLITE_PATH=$(zeolite --get-path) + +# Compile the example. +zeolite -p "$ZEOLITE_PATH" -i lib/util -m TreeDemo example/tree + +# Run the unit tests. +zeolite -p "$ZEOLITE_PATH" -t example/tree + +# Execute the compiled binary. +./TreeDemo +``` diff --git a/example/tree/tree-demo.0rx b/example/tree/tree-demo.0rx new file mode 100644 --- /dev/null +++ b/example/tree/tree-demo.0rx @@ -0,0 +1,54 @@ +concrete TreeDemo { + @type run () -> () +} + +define TreeDemo { + run () { + TypeTree tree <- TypeTree$new() + + TypeKey keyInt <- TypeKey$new() + TypeKey keyString <- TypeKey$new() + TypeKey keyFloat <- TypeKey$new() + TypeKey keyValue <- TypeKey$new() + + ~ tree.set(keyInt,1) + ~ tree.set(keyString,"a") + + ~ check(tree,keyInt) + ~ check(tree,keyString) + ~ check(tree,keyFloat) // Not found, since we never added a value. + + ~ tree.set(keyValue,Value$new()) + ~ check(tree,keyValue) + } + + @category check<#x> + #x requires Formatted + (TypeTree,TypeKey<#x>) -> () + check (tree,key) { + scoped { + optional #x value <- tree.get<#x>(key) + } in if (present(value)) { + ~ LazyStream$new() + .append("Found '") + .append(require(value)) + .append("'\n") + .writeTo(SimpleOutput$stderr()) + } else { + ~ LazyStream$new() + .append(typename>()) + .append(" Not Found\n") + .writeTo(SimpleOutput$stderr()) + } + } +} + +concrete Value { + refines Formatted + @type new () -> (Value) +} + +define Value { + new () { return Value{} } + formatted () { return "Value" } +} diff --git a/example/tree/tree-test.0rt b/example/tree/tree-test.0rt new file mode 100644 --- /dev/null +++ b/example/tree/tree-test.0rt @@ -0,0 +1,64 @@ +// Each testcase is essentially followed by its own private .0rx that is +// separate from all other testcases. In this case, the testcase expects that +// the source will compile and Test$execute() will succeed, but testcases can +// also expect a compiler error ("error") or a runtime crash ("crash"). Note +// that you *cannot* expect parse-time errors. + +testcase "integration test" { + success Test$execute() +} + +// Everything past the testcase (up until the next testcase, if there is one) is +// treated as a self-contained .0rx. This is compiled into a binary that calls +// the expression that follows "success" above. + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // Just select the required usage patterns with an intersection. + [KVWriter&KVReader] tree <- Tree$new() + Int count <- 30 + + // Insert values. + scoped { + Int i <- 0 + } in while (i < count) { + Int new <- ((i + 13) * 3547) % count + ~ tree.set(new,i) + } update { + i <- i+1 + } + + // Verify and remove values. + scoped { + Int i <- 0 + } in while (i < count) { + Int new <- ((i + 13) * 3547) % count + scoped { + optional Int value <- tree.get(new) + } in if (!present(value)) { + ~ LazyStream$new() + .append("Not found ") + .append(new) + .append(" but should have been ") + .append(i) + .writeTo(SimpleOutput$error()) + } elif (require(value) != i) { + ~ LazyStream$new() + .append("Element ") + .append(new) + .append(" should have been ") + .append(i) + .append(" but was ") + .append(require(value)) + .writeTo(SimpleOutput$error()) + } + ~ tree.remove(new) + } update { + i <- i+1 + } + } +} diff --git a/example/tree/tree.0rp b/example/tree/tree.0rp new file mode 100644 --- /dev/null +++ b/example/tree/tree.0rp @@ -0,0 +1,30 @@ +/* An interface for updating a key-value index. + */ +@value interface KVWriter<#k,#v|> { + set (#k,#v) -> (KVWriter<#k,#v>) + remove (#k) -> (KVWriter<#k,#v>) +} + +/* An interface for looking up values from a key-value index. + */ +@value interface KVReader<#k|#v> { + get (#k) -> (optional #v) +} + +/* An AVL implementation of KVWriter and KVReader. + */ +concrete Tree<#k,#v> { + refines KVWriter<#k,#v> + refines KVReader<#k,#v> + #k defines LessThan<#k> + + // Creates a new Tree, e.g., Tree$new(). + @type new () -> (Tree<#k,#v>) + + // Normally you do not need to redeclare functions inherited from interfaces. + // The two redeclarations below are used to refine the return type from + // KVWriter to Tree. + + @value set (#k,#v) -> (Tree<#k,#v>) + @value remove (#k) -> (Tree<#k,#v>) +} diff --git a/example/tree/tree.0rx b/example/tree/tree.0rx new file mode 100644 --- /dev/null +++ b/example/tree/tree.0rx @@ -0,0 +1,262 @@ +define Tree { + @value optional Node<#k,#v> root + + new () { + return Tree<#k,#v>{ empty } + } + + set (k,v) { + root <- Node<#k,#v>$insert(root,k,v) + return self + } + + remove (k) { + root <- Node<#k,#v>$delete(root,k) + return self + } + + get (k) { + return Node<#k,#v>$find(root,k) + } +} + +/* Represents the root of a subtree. + * + * Since this category is not declared in the .0rp, it is only visible within + * this .0rx file. + * + * This is separate from Tree so that the root can be empty, but Node otherwise + * handles all of the tree logic. + */ +concrete Node<#k,#v> { + #k defines LessThan<#k> + + // The functions below are the only ones visible to Tree. Other functions are + // declared in the definition of Node, and are only accessible to other + // functions within Node. + + @type insert (optional Node<#k,#v>,#k,#v) -> (optional Node<#k,#v>) + @type delete (optional Node<#k,#v>,#k) -> (optional Node<#k,#v>) + @type find (optional Node<#k,#v>,#k) -> (optional #v) +} + +define Node { + @value Int height + @value #k key + @value #v value + @value optional Node<#k,#v> lower + @value optional Node<#k,#v> higher + + insert (node,k,v) { + if (!present(node)) { + return Node<#k,#v>{ 1, k, v, empty, empty } + } + Node<#k,#v> node2 <- require(node) + if (k `#k$lessThan` node2.getKey()) { + ~ node2.setLower(insert(node2.getLower(),k,v)) + return rebalance(node2) + } elif (node2.getKey() `#k$lessThan` k) { + ~ node2.setHigher(insert(node2.getHigher(),k,v)) + return rebalance(node2) + } else { + ~ node2.setValue(v) + return node2 + } + } + + delete (node,k) { + if (!present(node)) { + return empty + } + Node<#k,#v> node2 <- require(node) + if (k `#k$lessThan` node2.getKey()) { + ~ node2.setLower(delete(node2.getLower(),k)) + return rebalance(node2) + } elif (node2.getKey() `#k$lessThan` k) { + ~ node2.setHigher(delete(node2.getHigher(),k)) + return rebalance(node2) + } else { + return rebalance(removeNode(node2)) + } + } + + find (node,k) { + if (present(node)) { + scoped { + Node<#k,#v> node2 <- require(node) + } in if (k `#k$lessThan` node2.getKey()) { + return find(node2.getLower(),k) + } elif (node2.getKey() `#k$lessThan` k) { + return find(node2.getHigher(),k) + } else { + return node2.getValue() + } + } else { + return empty + } + } + + @value updateHeight () -> () + updateHeight () { + scoped { + Int l <- 0 + Int h <- 0 + if (present(lower)) { + l <- require(lower).getHeight() + } + if (present(higher)) { + h <- require(higher).getHeight() + } + } in if (l > h) { + height <- l + 1 + } else { + height <- h + 1 + } + } + + @value getBalance () -> (Int) + getBalance () { + scoped { + Int l <- 0 + Int h <- 0 + if (present(lower)) { + l <- require(lower).getHeight() + } + if (present(higher)) { + h <- require(higher).getHeight() + } + } in return h - l + } + + @type rebalance (optional Node<#k,#v>) -> (optional Node<#k,#v>) + rebalance (node) { + if (!present(node)) { + return empty + } + Node<#k,#v> node2 <- require(node) + ~ node2.updateHeight() + scoped { + Int balance <- node2.getBalance() + } in if (balance > 1) { + return pivotLower(node2) + } elif (balance < -1) { + return pivotHigher(node2) + } else { + return node2 + } + } + + @type pivotHigher (Node<#k,#v>) -> (Node<#k,#v>) + pivotHigher (node) (newNode) { + if (require(node.getLower()).getBalance() > 0) { + ~ node.setLower(pivotLower(require(node.getLower()))) + } + newNode <- require(node.getLower()) + ~ node.setLower(newNode.getHigher()) + ~ node.updateHeight() + ~ newNode.setHigher(node) + ~ newNode.updateHeight() + } + + @type pivotLower (Node<#k,#v>) -> (Node<#k,#v>) + pivotLower (node) (newNode) { + if (require(node.getHigher()).getBalance() < 0) { + ~ node.setHigher(pivotHigher(require(node.getHigher()))) + } + newNode <- require(node.getHigher()) + ~ node.setHigher(newNode.getLower()) + ~ node.updateHeight() + ~ newNode.setLower(node) + ~ newNode.updateHeight() + } + + @type removeNode (Node<#k,#v>) -> (optional Node<#k,#v>) + removeNode (node) (newNode) { + if (node.getBalance() < 0) { + { optional Node<#k,#v> temp, newNode } <- removeHighest(node.getLower()) + ~ node.setLower(temp) + } else { + { optional Node<#k,#v> temp, newNode } <- removeLowest(node.getHigher()) + ~ node.setHigher(temp) + } + if (present(newNode)) { + ~ swapChildren(node,require(newNode)) + ~ require(newNode).updateHeight() + } + } + + @type removeHighest (optional Node<#k,#v>) -> (optional Node<#k,#v>,optional Node<#k,#v>) + removeHighest (node) (newNode,removed) { + if (!present(node)) { + return { empty, empty } + } + Node<#k,#v> node2 <- require(node) + if (present(node2.getHigher())) { + { optional Node<#k,#v> temp, removed } <- removeHighest(node2.getHigher()) + ~ node2.setHigher(temp) + newNode <- rebalance(node2) + } else { + newNode <- node2.getLower() + ~ node2.setLower(empty) + removed <- node + } + } + + @type removeLowest (optional Node<#k,#v>) -> (optional Node<#k,#v>,optional Node<#k,#v>) + removeLowest (node) (newNode,removed) { + if (!present(node)) { + return { empty, empty } + } + Node<#k,#v> node2 <- require(node) + if (present(node2.getLower())) { + { optional Node<#k,#v> temp, removed } <- removeLowest(node2.getLower()) + ~ node2.setLower(temp) + newNode <- rebalance(node2) + } else { + newNode <- node2.getHigher() + ~ node2.setHigher(empty) + removed <- node + } + } + + @type swapChildren (Node<#k,#v>,Node<#k,#v>) -> () + swapChildren (l,r) { + scoped { + optional Node<#k,#v> temp <- l.getLower() + ~ l.setLower(r.getLower()) + } in ~ r.setLower(temp) + scoped { + optional Node<#k,#v> temp <- l.getHigher() + ~ l.setHigher(r.getHigher()) + } in ~ r.setHigher(temp) + } + + @value getHeight () -> (Int) + getHeight () { return height } + + // It is unsafe to change the key after construction, so there is no setter. + // + // Unlike other languages, a member is only accessible by the value that owns + // it. More specifically, @type functions in Node can only access @value + // members via explicit @value getters and setters. + @value getKey () -> (#k) + getKey () { return key } + + @value getValue () -> (#v) + getValue () { return value } + + @value setValue (#v) -> () + setValue (v) { value <- v } + + @value getLower () -> (optional Node<#k,#v>) + getLower () { return lower } + + @value setLower (optional Node<#k,#v>) -> () + setLower (l) { lower <- l } + + @value getHigher () -> (optional Node<#k,#v>) + getHigher () { return higher } + + @value setHigher (optional Node<#k,#v>) -> () + setHigher (h) { higher <- h } +} diff --git a/example/tree/type-tree.0rp b/example/tree/type-tree.0rp new file mode 100644 --- /dev/null +++ b/example/tree/type-tree.0rp @@ -0,0 +1,50 @@ +/* A key-value index that can hold multiple types of value. + * + * Each element in the index is keyed by a TypeKey that has a type param that + * matches the type of the value. + */ +concrete TypeTree { + // Creates a new TypeTree, e.g., TypeTree$new(). + @type new () -> (TypeTree) + + // Sets the value for the given key, inserting if necessary. + @value set<#x> (TypeKey<#x>,#x) -> (TypeTree) + + // Removes the value for the given key. + @value remove (TypeKey) -> (TypeTree) + + // Returns the value for the given key, or empty if: + // - There is no entry for the key. + // - The value for the key is not of type #x, e.g., was originally added to + // the tree as a parent of type #x. + @value get<#x> (TypeKey<#x>) -> (optional #x) +} + +/* A typed key for indexing values in TypeTree. + * + * A key of type TypeKey<#x> indexes a value of type #x. The key can also be + * used as a key for any parent type of #x. For example, if V -> I then + * TypeKey can be used as TypeKey. + */ +concrete TypeKey<|#x> { + // Note that TypeKey<#x> as a type argument for some #y can satisfy + // + // #y defines LessThan<#y> + // + // even though we only define LessThan>. + // + // This is non-trivial: + // + // - #x -> any, which is trivial. + // - TypeKey<#x> -> TypeKey, since TypeKey has a single covariant param. + // - LessThan> -> LessThan>, since LessThan has a + // single contravariant param. + // - TypeKey<#x> -> LessThan> -> LessThan>. + // + // This means that TypeKey<#x> can be used as a key in Tree. (See tree.0rp.) + defines LessThan> + defines Equals> + + // Creates a new TypeKey, e.g., TypeTree<#x>$new(). + @type new () -> (TypeKey<#x>) +} diff --git a/example/tree/type-tree.0rx b/example/tree/type-tree.0rx new file mode 100644 --- /dev/null +++ b/example/tree/type-tree.0rx @@ -0,0 +1,93 @@ +define TypeTree { + // Since TypeKey and LockedType each have a covariant param, setting the param + // to any in Tree means that any param can be used in an assignment. + // + // The catch is that any cannot be converted to anything else, which means + // that type information is no longer directly accessible. LockedType allows + // the original type to be recovered via check, given the correct TypeKey. + @value Tree,LockedType> tree + + new () { + return TypeTree{ Tree,LockedType>$new() } + } + + set (k,v) { + ~ tree.set(k,LockedType$$create<#x>(k,v)) + return self + } + + remove (k) { + ~ tree.remove(k) + return self + } + + get (k) { + scoped { + optional LockedType value <- tree.get(k) + } in if (present(value)) { + return require(value).check<#x>(k) + } else { + return empty + } + } +} + +define TypeKey { + @category Int counter <- 0 + @value Int index + + new () { + return TypeKey<#x>{ (counter <- counter+1) } + } + + lessThan (l,r) { + return l.get() < r.get() + } + + equals (l,r) { + return l.get() == r.get() + } + + @value get () -> (Int) + get () { + return index + } +} + +/* An internal type used for storing a single value. + * + * The contained value is only accessible via the check function, which ensures + * both that the key and the type match. + */ +concrete LockedType<|#x> { + // Creates a new LockedType, e.g., LockedType$$create<#x>(k,v). + @category create<#x> (TypeKey<#x>,#x) -> (LockedType<#x>) + + // Returns the contained value if the key and type match, or empty otherwise. + @value check<#y> (TypeKey<#y>) -> (optional #y) +} + +define LockedType { + @value TypeKey<#x> key + @value #x value + + create (k,v) { + return LockedType<#x>{ k, v } + } + + check (k) { + if (key `TypeKey$equals` k) { + // reduce is a builtin that returns value (as optional #y) iff #x -> #y. + // The runtime type of value does not matter here; it just needs to be of + // type optional #x at compile time. + // + // This is more like template meta-programming in C++ than it is like a + // runtime type cast in Java. The reduce call could in theory be replaced + // at compile time with either value or empty if parameter substitution + // happened at compile time. (Like C++ does with templates.) + return reduce<#x,#y>(value) + } else { + return empty + } + } +} diff --git a/lib/file/.zeolite-module b/lib/file/.zeolite-module new file mode 100644 --- /dev/null +++ b/lib/file/.zeolite-module @@ -0,0 +1,1 @@ +RecompileMetadata {rmRoot = "..", rmPath = "file", rmPublicDeps = ["../util"], rmPrivateDeps = [], rmExtraFiles = ["file/Category_RawFileReader.cpp","file/Category_RawFileWriter.cpp"], rmExtraPaths = [], rmExtraRequires = [], rmMode = CompileUnspecified, rmOutputName = ""} diff --git a/lib/file/Category_RawFileReader.cpp b/lib/file/Category_RawFileReader.cpp new file mode 100644 --- /dev/null +++ b/lib/file/Category_RawFileReader.cpp @@ -0,0 +1,233 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#include + +#include "category-source.hpp" +#include "Category_String.hpp" +#include "Category_BlockReader.hpp" +#include "Category_PersistentResource.hpp" +#include "Category_RawFileReader.hpp" + + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +namespace ZEOLITE_DYNAMIC_NAMESPACE { +#endif // ZEOLITE_DYNAMIC_NAMESPACE + +namespace { +const int collection = 0; +} // namespace + +const void* const Functions_RawFileReader = &collection; +const TypeFunction& Function_RawFileReader_open = (*new TypeFunction{ 0, 1, 1, "RawFileReader", "open", Functions_RawFileReader, 0 }); +const ValueFunction& Function_RawFileReader_getFileError = (*new ValueFunction{ 0, 0, 1, "RawFileReader", "getFileError", Functions_RawFileReader, 0 }); + +namespace { +class Category_RawFileReader; +class Type_RawFileReader; +Type_RawFileReader& CreateType(Params<0>::Type params); +class Value_RawFileReader; +S CreateValue(Type_RawFileReader& parent, const ParamTuple& params, const ValueTuple& args); +struct Category_RawFileReader : public TypeCategory { + std::string CategoryName() const final { return "RawFileReader"; } + Category_RawFileReader() { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("RawFileReader (init @category)") + } + ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Category_RawFileReader::*)(const ParamTuple&, const ValueTuple&); + return TypeCategory::Dispatch(label, params, args); + } +}; +Category_RawFileReader& CreateCategory() { + static auto& category = *new Category_RawFileReader(); + return category; +} +struct Type_RawFileReader : public TypeInstance { + std::string CategoryName() const final { return parent.CategoryName(); } + void BuildTypeName(std::ostream& output) const final { + return TypeInstance::TypeNameFrom(output, parent); + } + Category_RawFileReader& parent; + bool CanConvertFrom(const TypeInstance& from) const final { + std::vector args; + if (!from.TypeArgsForParent(parent, args)) return false; + if(args.size() != 0) { + FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); + } + return true; + } + bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + if (&category == &GetCategory_RawFileReader()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_PersistentResource()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_BlockReader()) { + args = std::vector{&GetType_String(T_get())}; + return true; + } + return false; + } + Type_RawFileReader(Category_RawFileReader& p, Params<0>::Type params) : parent(p) { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("RawFileReader (init @type)") + } + ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Type_RawFileReader::*)(const ParamTuple&, const ValueTuple&); + static const CallType Table_RawFileReader[] = { + &Type_RawFileReader::Call_open, + }; + if (label.collection == Functions_RawFileReader) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_RawFileReader[label.function_num])(params, args); + } + return TypeInstance::Dispatch(label, params, args); + } + ReturnTuple Call_open(const ParamTuple& params, const ValueTuple& args); +}; +Type_RawFileReader& CreateType(Params<0>::Type params) { + static auto& cache = *new InstanceMap<0,Type_RawFileReader>(); + auto& cached = cache[params]; + if (!cached) { cached = R_get(new Type_RawFileReader(CreateCategory(), params)); } + return *cached; +} +struct Value_RawFileReader : public TypeValue { + Value_RawFileReader(Type_RawFileReader& p, const ParamTuple& params, const ValueTuple& args) + : parent(p), file(new std::ifstream(args.At(0)->AsString(), std::ios::in | std::ios::binary)) {} + + ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { + using CallType = ReturnTuple(Value_RawFileReader::*)(const S&, const ParamTuple&, const ValueTuple&); + static const CallType Table_BlockReader[] = { + &Value_RawFileReader::Call_pastEnd, + &Value_RawFileReader::Call_readBlock, + }; + static const CallType Table_PersistentResource[] = { + &Value_RawFileReader::Call_freeResource, + }; + static const CallType Table_RawFileReader[] = { + &Value_RawFileReader::Call_getFileError, + }; + if (label.collection == Functions_BlockReader) { + if (label.function_num < 0 || label.function_num >= 2) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_BlockReader[label.function_num])(self, params, args); + } + if (label.collection == Functions_PersistentResource) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_PersistentResource[label.function_num])(self, params, args); + } + if (label.collection == Functions_RawFileReader) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_RawFileReader[label.function_num])(self, params, args); + } + return TypeValue::Dispatch(self, label, params, args); + } + std::string CategoryName() const final { return parent.CategoryName(); } + ReturnTuple Call_freeResource(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_getFileError(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_pastEnd(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_readBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + Type_RawFileReader& parent; + + R file; +}; +S CreateValue(Type_RawFileReader& parent, const ParamTuple& params, const ValueTuple& args) { + return S_get(new Value_RawFileReader(parent, params, args)); +} + +ReturnTuple Type_RawFileReader::Call_open(const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileReader.create") + return ReturnTuple(CreateValue(*this, ParamTuple(), args)); +} + +ReturnTuple Value_RawFileReader::Call_freeResource(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileReader.freeResource") + if (file) { + file = nullptr; + } + return ReturnTuple(); +} + +ReturnTuple Value_RawFileReader::Call_getFileError(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileReader.getFileError") + if (!file) { + return ReturnTuple(Box_String(PrimString_FromLiteral("file has already been closed"))); + } + if (file->rdstate() & std::ios::badbit) { + return ReturnTuple(Box_String(PrimString_FromLiteral("file could not be read or opened"))); + } + if (file->rdstate() & std::ios::failbit) { + return ReturnTuple(Box_String(PrimString_FromLiteral("file could not be read or opened"))); + } + return ReturnTuple(Var_empty); +} + +ReturnTuple Value_RawFileReader::Call_pastEnd(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileReader.pastEnd") + return ReturnTuple(Box_Bool(!file || file->fail() || file->eof())); +} + +ReturnTuple Value_RawFileReader::Call_readBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileReader.readBlock") + const PrimInt Var_arg1 = (args.At(0))->AsInt(); + if (Var_arg1 < 0) { + FAIL() << "Read size " << Var_arg1 << " is invalid"; + } + std::string buffer(Var_arg1, '\x00'); + int read_size = 0; + if (file) { + const bool eof = file->eof(); + if (!eof && !file->fail()) { + file->read(&buffer[0], Var_arg1); + read_size = file->gcount(); + if (file->fail()) { + // Clear an EOF-related error, since we can't tell if it's because the + // file ended or because of a real error. + file->clear(); + file->setstate(std::ios::eofbit); + } + } + } + return ReturnTuple(Box_String(buffer.substr(0, read_size))); +} + +} // namespace +TypeCategory& GetCategory_RawFileReader() { + return CreateCategory(); +} +TypeInstance& GetType_RawFileReader(Params<0>::Type params) { + return CreateType(params); +} + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +} // namespace ZEOLITE_DYNAMIC_NAMESPACE +using namespace ZEOLITE_DYNAMIC_NAMESPACE; +#endif // ZEOLITE_DYNAMIC_NAMESPACE diff --git a/lib/file/Category_RawFileWriter.cpp b/lib/file/Category_RawFileWriter.cpp new file mode 100644 --- /dev/null +++ b/lib/file/Category_RawFileWriter.cpp @@ -0,0 +1,212 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#include + +#include "category-source.hpp" +#include "Category_String.hpp" +#include "Category_BlockWriter.hpp" +#include "Category_PersistentResource.hpp" +#include "Category_RawFileWriter.hpp" + + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +namespace ZEOLITE_DYNAMIC_NAMESPACE { +#endif // ZEOLITE_DYNAMIC_NAMESPACE + +namespace { +const int collection = 0; +} // namespace + +const void* const Functions_RawFileWriter = &collection; +const TypeFunction& Function_RawFileWriter_open = (*new TypeFunction{ 0, 1, 1, "RawFileWriter", "open", Functions_RawFileWriter, 0 }); +const ValueFunction& Function_RawFileWriter_getFileError = (*new ValueFunction{ 0, 0, 1, "RawFileWriter", "getFileError", Functions_RawFileWriter, 0 }); + +namespace { +class Category_RawFileWriter; +class Type_RawFileWriter; +Type_RawFileWriter& CreateType(Params<0>::Type params); +class Value_RawFileWriter; +S CreateValue(Type_RawFileWriter& parent, const ParamTuple& params, const ValueTuple& args); +struct Category_RawFileWriter : public TypeCategory { + std::string CategoryName() const final { return "RawFileWriter"; } + Category_RawFileWriter() { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("RawFileWriter (init @category)") + } + ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Category_RawFileWriter::*)(const ParamTuple&, const ValueTuple&); + return TypeCategory::Dispatch(label, params, args); + } +}; +Category_RawFileWriter& CreateCategory() { + static auto& category = *new Category_RawFileWriter(); + return category; +} +struct Type_RawFileWriter : public TypeInstance { + std::string CategoryName() const final { return parent.CategoryName(); } + void BuildTypeName(std::ostream& output) const final { + return TypeInstance::TypeNameFrom(output, parent); + } + Category_RawFileWriter& parent; + bool CanConvertFrom(const TypeInstance& from) const final { + std::vector args; + if (!from.TypeArgsForParent(parent, args)) return false; + if(args.size() != 0) { + FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); + } + return true; + } + bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + if (&category == &GetCategory_RawFileWriter()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_PersistentResource()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_BlockWriter()) { + args = std::vector{&GetType_String(T_get())}; + return true; + } + return false; + } + Type_RawFileWriter(Category_RawFileWriter& p, Params<0>::Type params) : parent(p) { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("RawFileWriter (init @type)") + } + ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Type_RawFileWriter::*)(const ParamTuple&, const ValueTuple&); + static const CallType Table_RawFileWriter[] = { + &Type_RawFileWriter::Call_open, + }; + if (label.collection == Functions_RawFileWriter) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_RawFileWriter[label.function_num])(params, args); + } + return TypeInstance::Dispatch(label, params, args); + } + ReturnTuple Call_open(const ParamTuple& params, const ValueTuple& args); +}; +Type_RawFileWriter& CreateType(Params<0>::Type params) { + static auto& cache = *new InstanceMap<0,Type_RawFileWriter>(); + auto& cached = cache[params]; + if (!cached) { cached = R_get(new Type_RawFileWriter(CreateCategory(), params)); } + return *cached; +} +struct Value_RawFileWriter : public TypeValue { + Value_RawFileWriter(Type_RawFileWriter& p, const ParamTuple& params, const ValueTuple& args) + : parent(p), file(new std::ofstream(args.At(0)->AsString(), std::ios::out | std::ios::binary | std::ios::trunc | std::ios::ate)) {} + + ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { + using CallType = ReturnTuple(Value_RawFileWriter::*)(const S&, const ParamTuple&, const ValueTuple&); + static const CallType Table_BlockWriter[] = { + &Value_RawFileWriter::Call_writeBlock, + }; + static const CallType Table_PersistentResource[] = { + &Value_RawFileWriter::Call_freeResource, + }; + static const CallType Table_RawFileWriter[] = { + &Value_RawFileWriter::Call_getFileError, + }; + if (label.collection == Functions_BlockWriter) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_BlockWriter[label.function_num])(self, params, args); + } + if (label.collection == Functions_PersistentResource) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_PersistentResource[label.function_num])(self, params, args); + } + if (label.collection == Functions_RawFileWriter) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_RawFileWriter[label.function_num])(self, params, args); + } + return TypeValue::Dispatch(self, label, params, args); + } + std::string CategoryName() const final { return parent.CategoryName(); } + ReturnTuple Call_freeResource(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_getFileError(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_writeBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + Type_RawFileWriter& parent; + + R file; +}; +S CreateValue(Type_RawFileWriter& parent, const ParamTuple& params, const ValueTuple& args) { + return S_get(new Value_RawFileWriter(parent, params, args)); +} + +ReturnTuple Type_RawFileWriter::Call_open(const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileWriter.create") + return ReturnTuple(CreateValue(*this, ParamTuple(), args)); +} +ReturnTuple Value_RawFileWriter::Call_freeResource(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileWriter.freeResource") + if (file) { + file = nullptr; + } + return ReturnTuple(); +} +ReturnTuple Value_RawFileWriter::Call_getFileError(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileWriter.getFileError") + if (!file) { + return ReturnTuple(Box_String(PrimString_FromLiteral("file has already been closed"))); + } + if (file->rdstate() & std::ios::badbit) { + return ReturnTuple(Box_String(PrimString_FromLiteral("file could not be written or opened"))); + } + if (file->rdstate() & std::ios::failbit) { + return ReturnTuple(Box_String(PrimString_FromLiteral("file could not be written or opened"))); + } + return ReturnTuple(Var_empty); +} +ReturnTuple Value_RawFileWriter::Call_writeBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileWriter.writeBlock") + const PrimString& Var_arg1 = args.At(0)->AsString(); + int write_size = 0; + if (file) { + file->write(&Var_arg1[0], Var_arg1.size()); + file->flush(); + write_size = file->fail()? 0 : Var_arg1.size(); + } + return ReturnTuple(Box_Int(write_size)); +} + +} // namespace + +TypeCategory& GetCategory_RawFileWriter() { + return CreateCategory(); +} +TypeInstance& GetType_RawFileWriter(Params<0>::Type params) { + return CreateType(params); +} + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +} // namespace ZEOLITE_DYNAMIC_NAMESPACE +using namespace ZEOLITE_DYNAMIC_NAMESPACE; +#endif // ZEOLITE_DYNAMIC_NAMESPACE diff --git a/lib/file/file.0rp b/lib/file/file.0rp new file mode 100644 --- /dev/null +++ b/lib/file/file.0rp @@ -0,0 +1,33 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +concrete RawFileReader { + refines PersistentResource + refines BlockReader + + @type open (String) -> (RawFileReader) + @value getFileError () -> (optional String) +} + +concrete RawFileWriter { + refines PersistentResource + refines BlockWriter + + @type open (String) -> (RawFileWriter) + @value getFileError () -> (optional String) +} diff --git a/lib/file/tests.0rt b/lib/file/tests.0rt new file mode 100644 --- /dev/null +++ b/lib/file/tests.0rt @@ -0,0 +1,140 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "read and write" { + success Test$run() +} + +define Test { + run () { + RawFileWriter writer <- RawFileWriter$open("testfile") + if (present(writer.getFileError())) { + fail(require(writer.getFileError())) + } + RawFileReader reader <- RawFileReader$open("testfile") + if (present(reader.getFileError())) { + fail(require(reader.getFileError())) + } + + String data <- "this is some\x00data" + + Int writeSize <- writer.writeBlock(data) + if (writeSize != data.readSize()) { + fail(writeSize) + } + if (present(writer.getFileError())) { + fail(require(writer.getFileError())) + } + + scoped { + String data2 <- reader.readBlock(8) + } in if (data2 != "this is ") { + fail("\"" + data2 + "\"") + } + scoped { + String data2 <- reader.readBlock(20) + } in if (data2 != "some\x00data") { + fail("\"" + data2 + "\"") + } + if (present(reader.getFileError())) { + fail(require(reader.getFileError())) + } + + if (!reader.pastEnd()) { + fail("more data in file") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "read empty file" { + success Test$run() +} + +define Test { + run () { + ~ RawFileWriter$open("testfile").freeResource() + RawFileReader reader <- RawFileReader$open("testfile") + + String data <- reader.readBlock(10) + if (data != "") { + fail("\"" + data + "\"") + } + if (present(reader.getFileError())) { + fail(require(reader.getFileError())) + } + if (!reader.pastEnd()) { + fail("more data in file") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "read missing file" { + success Test$run() +} + +define Test { + run () { + RawFileReader reader <- RawFileReader$open("do-not-create-this-file") + if (!present(reader.getFileError())) { + fail("expected file error") + } + + String data <- reader.readBlock(10) + if (data != "") { + fail("\"" + data + "\"") + } + if (!present(reader.getFileError())) { + fail("expected file error") + } + if (!reader.pastEnd()) { + fail("more data in file") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "unwritable file" { + success Test$run() +} + +define Test { + run () { + RawFileWriter writer <- RawFileWriter$open("/") + if (!present(writer.getFileError())) { + fail("expected file error") + } + } +} + +concrete Test { + @type run () -> () +} diff --git a/lib/util/.zeolite-module b/lib/util/.zeolite-module new file mode 100644 --- /dev/null +++ b/lib/util/.zeolite-module @@ -0,0 +1,1 @@ +RecompileMetadata {rmRoot = "..", rmPath = "util", rmPublicDeps = [], rmPrivateDeps = [], rmExtraFiles = ["util/Category_Argv.cpp","util/Category_SimpleInput.cpp","util/Category_SimpleOutput.cpp"], rmExtraPaths = [], rmExtraRequires = [], rmMode = CompileIncremental, rmOutputName = ""} diff --git a/lib/util/Category_Argv.cpp b/lib/util/Category_Argv.cpp new file mode 100644 --- /dev/null +++ b/lib/util/Category_Argv.cpp @@ -0,0 +1,160 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#include "category-source.hpp" +#include "Category_Argv.hpp" +#include "Category_ReadPosition.hpp" +#include "Category_String.hpp" + + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +namespace ZEOLITE_DYNAMIC_NAMESPACE { +#endif // ZEOLITE_DYNAMIC_NAMESPACE + +namespace { + +extern const S& Var_global; + +const int collection = 0; +} // namespace + +const void* const Functions_Argv = &collection; +const TypeFunction& Function_Argv_global = (*new TypeFunction{ 0, 0, 1, "Argv", "global", Functions_Argv, 0 }); + +namespace { +class Category_Argv; +class Type_Argv; +Type_Argv& CreateType(Params<0>::Type params); +class Value_Argv; +S CreateValue(Type_Argv& parent, const ParamTuple& params, const ValueTuple& args); +struct Category_Argv : public TypeCategory { + std::string CategoryName() const final { return "Argv"; } + Category_Argv() { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("Argv (init @category)") + } + ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Category_Argv::*)(const ParamTuple&, const ValueTuple&); + return TypeCategory::Dispatch(label, params, args); + } +}; +Category_Argv& CreateCategory() { + static auto& category = *new Category_Argv(); + return category; +} +struct Type_Argv : public TypeInstance { + std::string CategoryName() const final { return parent.CategoryName(); } + void BuildTypeName(std::ostream& output) const final { + return TypeInstance::TypeNameFrom(output, parent); + } + Category_Argv& parent; + bool CanConvertFrom(const TypeInstance& from) const final { + std::vector args; + if (!from.TypeArgsForParent(parent, args)) return false; + if(args.size() != 0) { + FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); + } + return true; + } + bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + if (&category == &GetCategory_Argv()) { + args = std::vector{}; + return true; + } + if (&category == &GetCategory_ReadPosition()) { + args = std::vector{&GetType_String(T_get())}; + return true; + } + return false; + } + Type_Argv(Category_Argv& p, Params<0>::Type params) : parent(p) { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("Argv (init @type)") + } + ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Type_Argv::*)(const ParamTuple&, const ValueTuple&); + static const CallType Table_Argv[] = { + &Type_Argv::Call_global, + }; + if (label.collection == Functions_Argv) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_Argv[label.function_num])(params, args); + } + return TypeInstance::Dispatch(label, params, args); + } + ReturnTuple Call_global(const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Argv.global") + return ReturnTuple(Var_global); + } +}; +Type_Argv& CreateType(Params<0>::Type params) { + static auto& cache = *new InstanceMap<0,Type_Argv>(); + auto& cached = cache[params]; + if (!cached) { cached = R_get(new Type_Argv(CreateCategory(), params)); } + return *cached; +} +struct Value_Argv : public TypeValue { + Value_Argv(Type_Argv& p, const ParamTuple& params, const ValueTuple& args) : parent(p) {} + ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { + using CallType = ReturnTuple(Value_Argv::*)(const S&, const ParamTuple&, const ValueTuple&); + static const CallType Table_ReadPosition[] = { + &Value_Argv::Call_readPosition, + &Value_Argv::Call_readSize, + }; + if (label.collection == Functions_ReadPosition) { + if (label.function_num < 0 || label.function_num >= 2) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_ReadPosition[label.function_num])(self, params, args); + } + return TypeValue::Dispatch(self, label, params, args); + } + std::string CategoryName() const final { return parent.CategoryName(); } + ReturnTuple Call_readPosition(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Argv.readPosition") + const PrimInt Var_arg1 = (args.At(0))->AsInt(); + return ReturnTuple(Box_String(Argv::GetArgAt(Var_arg1))); + } + ReturnTuple Call_readSize(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Argv.readSize") + return ReturnTuple(Box_Int(Argv::ArgCount())); + } + Type_Argv& parent; +}; +S CreateValue(Type_Argv& parent, const ParamTuple& params, const ValueTuple& args) { + return S_get(new Value_Argv(parent, params, args)); +} + +const S& Var_global = *new S(CreateValue(CreateType(Params<0>::Type()), ParamTuple(), ArgTuple())); + +} // namespace + +TypeCategory& GetCategory_Argv() { + return CreateCategory(); +} +TypeInstance& GetType_Argv(Params<0>::Type params) { + return CreateType(params); +} + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +} // namespace ZEOLITE_DYNAMIC_NAMESPACE +#endif // ZEOLITE_DYNAMIC_NAMESPACE diff --git a/lib/util/Category_SimpleInput.cpp b/lib/util/Category_SimpleInput.cpp new file mode 100644 --- /dev/null +++ b/lib/util/Category_SimpleInput.cpp @@ -0,0 +1,167 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +// TODO: Maybe use C++ instead. +#include + +#include "category-source.hpp" +#include "Category_SimpleInput.hpp" +#include "Category_BlockReader.hpp" + + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +namespace ZEOLITE_DYNAMIC_NAMESPACE { +#endif // ZEOLITE_DYNAMIC_NAMESPACE + +namespace { +extern const S& Var_stdin; + +const int collection = 0; +} // namespace + +const void* const Functions_SimpleInput = &collection; +const TypeFunction& Function_SimpleInput_stdin = (*new TypeFunction{ 0, 0, 1, "SimpleInput", "stdin", Functions_SimpleInput, 0 }); + +namespace { +class Category_SimpleInput; +class Type_SimpleInput; +Type_SimpleInput& CreateType(Params<0>::Type params); +class Value_SimpleInput; +S CreateValue(Type_SimpleInput& parent, const ParamTuple& params, const ValueTuple& args); +struct Category_SimpleInput : public TypeCategory { + std::string CategoryName() const final { return "SimpleInput"; } + Category_SimpleInput() { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("SimpleInput (init @category)") + } + ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Category_SimpleInput::*)(const ParamTuple&, const ValueTuple&); + return TypeCategory::Dispatch(label, params, args); + } +}; +Category_SimpleInput& CreateCategory() { + static auto& category = *new Category_SimpleInput(); + return category; +} +struct Type_SimpleInput : public TypeInstance { + std::string CategoryName() const final { return parent.CategoryName(); } + void BuildTypeName(std::ostream& output) const final { + return TypeInstance::TypeNameFrom(output, parent); + } + Category_SimpleInput& parent; + bool CanConvertFrom(const TypeInstance& from) const final { + std::vector args; + if (!from.TypeArgsForParent(parent, args)) return false; + if(args.size() != 0) { + FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); + } + return true; + } + bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + if (&category == &GetCategory_SimpleInput()) { + args = std::vector{}; + return true; + } + return false; + } + Type_SimpleInput(Category_SimpleInput& p, Params<0>::Type params) : parent(p) { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("SimpleInput (init @type)") + } + ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Type_SimpleInput::*)(const ParamTuple&, const ValueTuple&); + static const CallType Table_SimpleInput[] = { + &Type_SimpleInput::Call_stdin, + }; + if (label.collection == Functions_SimpleInput) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_SimpleInput[label.function_num])(params, args); + } + return TypeInstance::Dispatch(label, params, args); + } + ReturnTuple Call_stdin(const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("SimpleInput.stdin") + return ReturnTuple(Var_stdin); + } +}; +Type_SimpleInput& CreateType(Params<0>::Type params) { + static auto& cache = *new InstanceMap<0,Type_SimpleInput>(); + auto& cached = cache[params]; + if (!cached) { cached = R_get(new Type_SimpleInput(CreateCategory(), params)); } + return *cached; +} +struct Value_SimpleInput : public TypeValue { + Value_SimpleInput(Type_SimpleInput& p, const ParamTuple& params, const ValueTuple& args) : parent(p) {} + + ReturnTuple Dispatch(const S& self, + const ValueFunction& label, + const ParamTuple& params, const ValueTuple& args) final { + if (args.Size() != label.arg_count) { + FAIL() << "Wrong number of args"; + } + if (params.Size() != label.param_count){ + FAIL() << "Wrong number of params"; + } + if (&label == &Function_BlockReader_readBlock) { + TRACE_FUNCTION("SimpleInput.readBlock") + const int size = args.At(0)->AsInt(); + if (size < 0) { + FAIL() << "Read size " << size << " is invalid"; + } + std::string buffer(size, '\x00'); + const int read_size = read(STDIN_FILENO, &buffer[0], size); + if (read_size < 0) { + return ReturnTuple(Box_String("")); + } else { + zero_read = read_size == 0; + return ReturnTuple(Box_String(buffer.substr(0, read_size))); + } + } + if (&label == &Function_BlockReader_pastEnd) { + return ReturnTuple(Box_Bool(zero_read)); + } + return TypeValue::Dispatch(self, label, params, args); + } + + std::string CategoryName() const final { return parent.CategoryName(); } + bool zero_read = false; + Type_SimpleInput& parent; +}; +S CreateValue(Type_SimpleInput& parent, const ParamTuple& params, const ValueTuple& args) { + return S_get(new Value_SimpleInput(parent, params, args)); +} + +const S& Var_stdin = *new S(CreateValue(CreateType(Params<0>::Type()), ParamTuple(), ArgTuple())); + +} // namespace + +TypeCategory& GetCategory_SimpleInput() { + return CreateCategory(); +} +TypeInstance& GetType_SimpleInput(Params<0>::Type params) { + return CreateType(params); +} + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +} // namespace ZEOLITE_DYNAMIC_NAMESPACE +using namespace ZEOLITE_DYNAMIC_NAMESPACE; +#endif // ZEOLITE_DYNAMIC_NAMESPACE diff --git a/lib/util/Category_SimpleOutput.cpp b/lib/util/Category_SimpleOutput.cpp new file mode 100644 --- /dev/null +++ b/lib/util/Category_SimpleOutput.cpp @@ -0,0 +1,164 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +// Hand-written implementation of SimpleOutput. + +#include "Category_SimpleOutput.hpp" + +#include +#include + +#include "category-source.hpp" +#include "Category_Formatted.hpp" +#include "Category_Writer.hpp" +#include "Category_BufferedWriter.hpp" + + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +namespace ZEOLITE_DYNAMIC_NAMESPACE { +#endif // ZEOLITE_DYNAMIC_NAMESPACE + +namespace { +const int collection = 0; +} + +const void* const Functions_SimpleOutput = &collection; + +const TypeFunction& Function_SimpleOutput_stdout = + *new TypeFunction{ 0, 0, 1, "SimpleOutput", "stdout", Functions_SimpleOutput, 0 }; +const TypeFunction& Function_SimpleOutput_stderr = + *new TypeFunction{ 0, 0, 1, "SimpleOutput", "stderr", Functions_SimpleOutput, 1 }; +const TypeFunction& Function_SimpleOutput_error = + *new TypeFunction{ 0, 0, 1, "SimpleOutput", "error", Functions_SimpleOutput, 2 }; + +namespace { + +extern const S& Var_stdout; +extern const S& Var_stderr; +extern const S& Var_error; + +struct Category_SimpleOutput : public TypeCategory { + std::string CategoryName() const final { return "SimpleOutput"; } +}; + +struct Type_SimpleOutput : public TypeInstance { + std::string CategoryName() const final { return "SimpleOutput"; } + void BuildTypeName(std::ostream& output) const final { output << CategoryName(); } + + ReturnTuple Dispatch(const TypeFunction& label, + const ParamTuple& params, const ValueTuple& args) final { + if (args.Size() != label.arg_count) { + FAIL() << "Wrong number of args"; + } + if (params.Size() != label.param_count){ + FAIL() << "Wrong number of params"; + } + if (&label == &Function_SimpleOutput_stdout) { + return ReturnTuple(Var_stdout); + } + if (&label == &Function_SimpleOutput_stderr) { + return ReturnTuple(Var_stderr); + } + if (&label == &Function_SimpleOutput_error) { + return ReturnTuple(Var_error); + } + return TypeInstance::Dispatch(label, params, args); + } +}; + +class Value_SimpleOutput : public TypeValue { + public: + Value_SimpleOutput(std::ostream& output) : output_(output) {} + + std::string CategoryName() const final { return "SimpleOutput"; } + + ReturnTuple Dispatch(const S& self, + const ValueFunction& label, + const ParamTuple& params, const ValueTuple& args) final { + if (args.Size() != label.arg_count) { + FAIL() << "Wrong number of args"; + } + if (params.Size() != label.param_count){ + FAIL() << "Wrong number of params"; + } + if (&label == &Function_Writer_write) { + TRACE_FUNCTION("SimpleOutput.write") + output_ << TypeValue::Call(args.At(0), Function_Formatted_formatted, + ParamTuple(), ArgTuple()).Only()->AsString(); + return ReturnTuple(); + } + if (&label == &Function_BufferedWriter_flush) { + return ReturnTuple(); + } + return TypeValue::Dispatch(self, label, params, args); + } + + private: + std::ostream& output_; +}; + +class Value_SimpleError : public TypeValue { + public: + std::string CategoryName() const final { return "SimpleError"; } + + ReturnTuple Dispatch(const S& self, + const ValueFunction& label, + const ParamTuple& params, const ValueTuple& args) final { + if (args.Size() != label.arg_count) { + FAIL() << "Wrong number of args"; + } + if (params.Size() != label.param_count){ + FAIL() << "Wrong number of params"; + } + if (&label == &Function_Writer_write) { + TRACE_FUNCTION("SimpleOutput.write") + output_ << TypeValue::Call(args.At(0), Function_Formatted_formatted, + ParamTuple(), ArgTuple()).Only()->AsString(); + return ReturnTuple(); + } + if (&label == &Function_BufferedWriter_flush) { + TRACE_FUNCTION("SimpleOutput.flush") + FAIL() << output_.str(); + return ReturnTuple(); + } + return TypeValue::Dispatch(self, label, params, args); + } + + private: + std::ostringstream output_; +}; + +const S& Var_stdout = *new S(new Value_SimpleOutput(std::cout)); +const S& Var_stderr = *new S(new Value_SimpleOutput(std::cerr)); +const S& Var_error = *new S(new Value_SimpleError()); + +} // namespace + +TypeCategory& GetCategory_SimpleOutput() { + static auto& category = *new Category_SimpleOutput(); + return category; +} + +TypeInstance& GetType_SimpleOutput(Params<0>::Type) { + static auto& instance = *new Type_SimpleOutput(); + return instance; +} + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +} // namespace ZEOLITE_DYNAMIC_NAMESPACE +#endif // ZEOLITE_DYNAMIC_NAMESPACE diff --git a/lib/util/tests.0rt b/lib/util/tests.0rt new file mode 100644 --- /dev/null +++ b/lib/util/tests.0rt @@ -0,0 +1,219 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "stdout writer" { + success Test$run() + require stdout "message" + exclude stderr "message" +} + +define Test { + run () { + ~ LazyStream$new().append("message").writeTo(SimpleOutput$stdout()) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "stderr writer" { + success Test$run() + require stderr "message" + exclude stdout "message" +} + +define Test { + run () { + ~ LazyStream$new().append("message").writeTo(SimpleOutput$stderr()) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "error writer" { + crash Test$run() + require "message" +} + +define Test { + run () { + ~ LazyStream$new().append("message").writeTo(SimpleOutput$error()) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "iterate String forward" { + success Test$run() +} + +define Test { + run () { + String s <- "abcde" + Int count <- 0 + scoped { + ReadIterator iter <- ReadIterator$$fromReadPosition(s) + } in while (!iter.pastForwardEnd()) { + if (iter.readCurrent() != s.readPosition(count)) { + fail(iter.readCurrent()) + } + } update { + count <- count+1 + iter <- iter.forward() + } + if (count != s.readSize()) { + fail(count) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "iterate String reverse" { + success Test$run() +} + +define Test { + run () { + String s <- "abcde" + Int count <- s.readSize()-1 + scoped { + ReadIterator iter <- ReadIterator$$fromReadPositionAt(s,count) + } in while (!iter.pastReverseEnd()) { + if (iter.readCurrent() != s.readPosition(count)) { + fail(iter.readCurrent()) + } + } update { + count <- count-1 + iter <- iter.reverse() + } + if (count != -1) { + fail(count) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Argv is set and available" { + success Test$run() + require stdout "/testcase$" +} + +define Test { + run () { + Int count <- Argv$global().readSize() + if (count != 1) { + fail(count) + } + String name <- Argv$global().readPosition(0) + ~ LazyStream$new() + .append(name) + .append("\n") + .writeTo(SimpleOutput$stdout()) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "TextReader splits lines correctly" { + success Test$run() +} + +concrete FakeFile { + refines BlockReader + + @type create () -> (FakeFile) +} + +define FakeFile { + @value Int counter + + create () { + return FakeFile{ 0 } + } + + readBlock (_) { + cleanup { + counter <- counter+1 + } in if (counter == 0) { + return "this is a " + } elif (counter == 1) { + return "partial line\nwith " + } elif (counter == 2) { + return "some more data\nand\nmore lines" + } elif (counter == 3) { + return "\nunfinished" + } else { + fail("too many reads") + } + } + + pastEnd () { + return counter > 3 + } +} + +define Test { + run () { + TextReader reader <- TextReader$fromBlockReader(FakeFile$create()) + ~ checkNext(reader,"this is a partial line") + ~ checkNext(reader,"with some more data") + ~ checkNext(reader,"and") + ~ checkNext(reader,"more lines") + ~ checkNext(reader,"unfinished") + if (!reader.pastEnd()) { + fail("not past end") + } + if (reader.readNextLine() != "") { + fail("reused data") + } + } + + @type checkNext (TextReader,String) -> () + checkNext (reader,line) { + if (reader.pastEnd()) { + fail("past end") + } + String value <- reader.readNextLine() + if (value != line) { + fail(value) + } + } +} + +concrete Test { + @type run () -> () +} diff --git a/lib/util/util.0rp b/lib/util/util.0rp new file mode 100644 --- /dev/null +++ b/lib/util/util.0rp @@ -0,0 +1,93 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +// TODO: Split this up, or otherwise organize it better. + +@value interface ReadCurrent<|#x> { + readCurrent () -> (#x) +} + +@value interface IterateForward<|#x> { + forward () -> (#x) + pastForwardEnd () -> (Bool) +} + +@value interface IterateReverse<|#x> { + reverse () -> (#x) + pastReverseEnd () -> (Bool) +} + +concrete ReadIterator<|#x> { + refines ReadCurrent<#x> + refines IterateForward> + refines IterateReverse> + + @category fromReadPosition<#y> (ReadPosition<#y>) -> (ReadIterator<#y>) + @category fromReadPositionAt<#y> (ReadPosition<#y>,Int) -> (ReadIterator<#y>) +} + +@value interface Writer<#x|> { + write (#x) -> () +} + +@value interface BufferedWriter<#x|> { + refines Writer<#x> + + flush () -> () +} + +concrete LazyStream<#x> { + @type new () -> (LazyStream<#x>) + @value append (#x) -> (LazyStream<#x>) + @value writeTo (BufferedWriter<#x>) -> () +} + +concrete SimpleOutput { + @type stdout () -> (BufferedWriter) + @type stderr () -> (BufferedWriter) + @type error () -> (BufferedWriter) +} + +concrete SimpleInput { + @type stdin () -> (BlockReader) +} + +concrete Argv { + refines ReadPosition + + @type global () -> (ReadPosition) +} + +@value interface PersistentResource { + freeResource () -> () +} + +@value interface BlockReader<|#x> { + readBlock (Int) -> (#x) + pastEnd () -> (Bool) +} + +@value interface BlockWriter<#x|> { + writeBlock (#x) -> (Int) +} + +concrete TextReader { + @type fromBlockReader (BlockReader) -> (TextReader) + @value readNextLine () -> (String) + @value pastEnd () -> (Bool) +} diff --git a/lib/util/util.0rx b/lib/util/util.0rx new file mode 100644 --- /dev/null +++ b/lib/util/util.0rx @@ -0,0 +1,147 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +define ReadIterator { + @value ReadPosition<#x> reader + @value Int position + + fromReadPosition (reader) { + return fromReadPositionAt<#y>(reader,0) + } + + fromReadPositionAt (reader,position) { + Int position2 <- position + if (position < 0) { + position2 <- -1 + } + if (position >= reader.readSize() || reader.readSize() == 0) { + position2 <- reader.readSize() + } + return ReadIterator<#y>{ reader, position } + } + + readCurrent () { + if (pastForwardEnd() || pastReverseEnd()) { + ~ LazyStream$new() + .append("Position ") + .append(position) + .append(" is out of bounds") + .writeTo(SimpleOutput$error()) + } + return reader.readPosition(position) + } + + forward () { + return fromReadPositionAt<#x>(reader,position+1) + } + + pastForwardEnd () { + return position >= reader.readSize() + } + + reverse () { + return fromReadPositionAt<#x>(reader,position-1) + } + + pastReverseEnd () { + return position < 0 || reader.readSize() == 0 + } +} + +define LazyStream { + @value optional #x value + @value optional LazyStream<#x> next + + new () { + return LazyStream<#x>{ empty, empty } + } + + append (value2) { + return LazyStream<#x>{ value2, self } + } + + @value recursive (Writer<#x>) -> () + recursive (writer) { + if (present(next)) { + ~ require(next).recursive(writer) + } + if (present(value)) { + ~ writer.write(require(value)) + } + } + + writeTo (writer) { + ~ recursive(writer) + ~ writer.flush() + } +} + +define TextReader { + @value BlockReader reader + @value String buffer + + fromBlockReader (reader) { + return TextReader{ reader, "" } + } + + readNextLine () { + while (true) { + Int newline <- findNewline() + if (newline < 0) { + if (reader.pastEnd()) { + cleanup { + buffer <- "" + } in return buffer + } else { + // TODO: Maybe the block size should be a factory argument. + buffer <- buffer+reader.readBlock(\x100) + } + } else { + return takeLine(newline) + } + } + return "" + } + + pastEnd () { + return buffer.readSize() == 0 && reader.pastEnd() + } + + @value findNewline () -> (Int) + findNewline () { + scoped { + Int position <- 0 + } in while (position < buffer.readSize()) { + Char c <- buffer.readPosition(position) + // TODO: Maybe the line separator should be a factory argument. + if (c == '\n' || c == '\r') { + return position + } + } update { + position <- position+1 + } + return -1 + } + + @value takeLine (Int) -> (String) + takeLine (position) { + String data <- buffer.subSequence(0,position) + buffer <- buffer.subSequence(position+1,buffer.readSize()-position-1) + return data + } +} diff --git a/src/Base/CompileError.hs b/src/Base/CompileError.hs new file mode 100644 --- /dev/null +++ b/src/Base/CompileError.hs @@ -0,0 +1,61 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} + +module Base.CompileError ( + CompileError(..), + CompileErrorM(..), +) where + +import Control.Monad (Monad(..)) + +#if MIN_VERSION_base(4,9,0) +import Control.Monad.Fail +#endif + + +class CompileError a where + compileError :: String -> a + isCompileError :: a -> Bool + reviseError :: a -> String -> a + reviseError e _ = e + +-- For some GHC versions, pattern-matching failures require MonadFail. +#if MIN_VERSION_base(4,9,0) +class (Monad m, MonadFail m) => CompileErrorM m where +#else +class Monad m => CompileErrorM m where +#endif + compileErrorM :: String -> m a +#if MIN_VERSION_base(4,9,0) + compileErrorM = fail +#endif + isCompileErrorM :: m a -> Bool + collectAllOrErrorM :: Foldable f => f (m a) -> m [a] + collectOneOrErrorM :: Foldable f => f (m a) -> m a + reviseErrorM :: m a -> String -> m a + reviseErrorM e _ = e + compileWarningM :: String -> m () + +instance CompileErrorM m => CompileError (m a) where + compileError = compileErrorM + isCompileError = isCompileErrorM + reviseError = reviseErrorM diff --git a/src/Base/Mergeable.hs b/src/Base/Mergeable.hs new file mode 100644 --- /dev/null +++ b/src/Base/Mergeable.hs @@ -0,0 +1,57 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} + +module Base.Mergeable ( + Mergeable(..), + MergeableM(..), +) where + +import Control.Monad (Monad(..)) + + +class Mergeable a where + mergeAny :: Foldable f => f a -> a + mergeAll :: Foldable f => f a -> a + mergeNested :: a -> a -> a + mergeNested x y = mergeAll [x,y] + mergeDefault :: a + mergeDefault = mergeAll Nothing + +class Monad m => MergeableM m where + mergeAnyM :: (Mergeable a, Foldable f) => f (m a) -> m a + mergeAllM :: (Mergeable a, Foldable f) => f (m a) -> m a + mergeNestedM :: Mergeable a => m a -> m a -> m a + mergeNestedM x y = mergeAllM [x,y] + mergeDefaultM :: Mergeable a => m a + mergeDefaultM = mergeAllM Nothing + +instance Mergeable () where + mergeAny = const () + mergeAll = const () + +instance Mergeable Bool where + mergeAny = any id + mergeAll = all id + +instance Mergeable [a] where + mergeAny = foldr (++) [] + mergeAll = foldr (++) [] diff --git a/src/Cli/CompileMetadata.hs b/src/Cli/CompileMetadata.hs new file mode 100644 --- /dev/null +++ b/src/Cli/CompileMetadata.hs @@ -0,0 +1,399 @@ +{- ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Cli.CompileMetadata ( + CategoryIdentifier(..), + CompileMetadata(..), + ObjectFile(..), + RecompileMetadata(..), + allowedExtraTypes, + createCachePath, + eraseCachedData, + findSourceFiles, + fixPath, + getCachedPath, + getCacheRelativePath, + getIncludePathsForDeps, + getNamespacesForDeps, + getObjectFilesForDeps, + getObjectFileResolver, + getRealPathsForDeps, + getRequiresFromDeps, + getSourceFilesForDeps, + isCategoryObjectFile, + isPathConfigured, + isPathUpToDate, + loadPrivateDeps, + loadPublicDeps, + loadMetadata, + mergeObjectFiles, + resolveCategoryDeps, + resolveObjectDeps, + sortCompiledFiles, + tryLoadRecompile, + writeCachedFile, + writeMetadata, + writeRecompile, +) where + +import Control.Applicative ((<|>)) +import Control.Monad (when) +import Data.List (nub,isSuffixOf) +import Data.Maybe (isJust) +import System.Directory +import System.Environment +import System.Exit (exitFailure) +import System.FilePath +import System.IO +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Cli.CompileOptions (CompileMode) +import CompilerCxx.Category (CxxOutput(..)) +import Types.TypeCategory +import Types.TypeInstance + + +data CompileMetadata = + CompileMetadata { + cmPath :: String, + cmNamespace :: String, -- TODO: Use Namespace here? + cmPublicDeps :: [String], + cmPrivateDeps :: [String], + cmExtraRequires :: [CategoryIdentifier], + cmCategories :: [String], + cmSubdirs :: [String], + cmPublicFiles :: [String], + cmPrivateFiles :: [String], + cmTestFiles :: [String], + cmHxxFiles :: [String], + cmCxxFiles :: [String], + cmObjectFiles :: [ObjectFile] + } + deriving (Show,Read) + +data ObjectFile = + CategoryObjectFile { + cofCategory :: CategoryIdentifier, + cofRequires :: [CategoryIdentifier], + cofFiles :: [String] + } | + OtherObjectFile { + oofFile :: String + } + deriving (Show,Read) + +data CategoryIdentifier = + CategoryIdentifier { + ciPath :: String, + ciCategory :: String, + ciNamespace :: String + } | + UnresolvedCategory { + ucCategory :: String + } + deriving (Eq,Ord,Show,Read) + +mergeObjectFiles :: ObjectFile -> ObjectFile -> ObjectFile +mergeObjectFiles (CategoryObjectFile c rs1 fs1) (CategoryObjectFile _ rs2 fs2) = + CategoryObjectFile c (rs1 ++ rs2) (fs1 ++ fs2) +mergeObjectFiles o _ = o + +isCategoryObjectFile :: ObjectFile -> Bool +isCategoryObjectFile (CategoryObjectFile _ _ _) = True +isCategoryObjectFile (OtherObjectFile _) = False + +data RecompileMetadata = + RecompileMetadata { + rmRoot :: String, + rmPath :: String, + rmPublicDeps :: [String], + rmPrivateDeps :: [String], + rmExtraFiles :: [String], + rmExtraPaths :: [String], + rmExtraRequires :: [String], + rmMode :: CompileMode, + rmOutputName :: String + } + deriving (Show,Read) + +cachedDataPath = ".zeolite-cache" +recompileFilename = ".zeolite-module" +metadataFilename = "metadata.txt" +allowedExtraTypes = [".hpp",".cpp",".h",".cc",".a",".o"] + +loadMetadata :: String -> IO CompileMetadata +loadMetadata p = do + let f = p cachedDataPath metadataFilename + isFile <- doesFileExist p + when isFile $ do + hPutStrLn stderr $ "Path \"" ++ p ++ "\" is not a directory." + exitFailure + isDir <- doesDirectoryExist p + when (not isDir) $ do + hPutStrLn stderr $ "Path \"" ++ p ++ "\" does not exist." + exitFailure + filePresent <- doesFileExist f + when (not filePresent) $ do + hPutStrLn stderr $ "Module \"" ++ p ++ "\" has not been compiled yet." + exitFailure + c <- readFile f + m <- check $ (reads c :: [(CompileMetadata,String)]) + return m where + check [(cm,"")] = return cm + check [(cm,"\n")] = return cm + check _ = do + hPutStrLn stderr $ "Could not parse metadata from \"" ++ p ++ "\"; please recompile." + exitFailure + +tryLoadMetadata :: String -> IO (Maybe CompileMetadata) +tryLoadMetadata p = tryLoadData $ (p cachedDataPath metadataFilename) + +tryLoadRecompile :: String -> IO (Maybe RecompileMetadata) +tryLoadRecompile p = tryLoadData $ (p recompileFilename) + +tryLoadData :: Read a => String -> IO (Maybe a) +tryLoadData f = do + filePresent <- doesFileExist f + if not filePresent + then return Nothing + else do + c <- readFile f + check (reads c) where + check [(cm,"")] = return (Just cm) + check [(cm,"\n")] = return (Just cm) + check _ = return Nothing + +isPathUpToDate :: String -> IO Bool +isPathUpToDate p = do + m <- tryLoadMetadata p + case m of + Nothing -> return False + Just m'-> do + (fr,_) <- loadDepsCommon True (\m -> cmPublicDeps m ++ cmPrivateDeps m) [p] + return fr + +isPathConfigured :: String -> IO Bool +isPathConfigured p = tryLoadRecompile p >>= return . isJust + +writeMetadata :: String -> CompileMetadata -> IO () +writeMetadata p m = do + p' <- canonicalizePath p + hPutStrLn stderr $ "Writing metadata for \"" ++ p' ++ "\"." + writeCachedFile p' "" metadataFilename (show m ++ "\n") + +writeRecompile :: String -> RecompileMetadata -> IO () +writeRecompile p m = do + p' <- canonicalizePath p + hPutStrLn stderr $ "Updating config for \"" ++ p' ++ "\"." + writeFile (p recompileFilename) (show m ++ "\n") + +eraseCachedData :: String -> IO () +eraseCachedData p = do + let d = p cachedDataPath + dirExists <- doesDirectoryExist d + when dirExists $ removeDirectoryRecursive d + +createCachePath :: String -> IO () +createCachePath p = do + let f = p cachedDataPath + exists <- doesDirectoryExist f + when (not exists) $ createDirectoryIfMissing False f + +writeCachedFile :: String -> String -> String -> String -> IO () +writeCachedFile p ns f c = do + createCachePath p + createDirectoryIfMissing False $ p cachedDataPath ns + writeFile (getCachedPath p ns f) c + +getCachedPath :: String -> String -> String -> String +getCachedPath p ns f = fixPath $ p cachedDataPath ns f + +getCacheRelativePath :: String -> String +getCacheRelativePath f = ".." f + +findSourceFiles :: String -> String -> IO ([String],[String],[String]) +findSourceFiles p0 p = do + let absolute = p0 p + isFile <- doesFileExist absolute + when isFile $ do + hPutStrLn stderr $ "Path \"" ++ absolute ++ "\" is not a directory." + exitFailure + isDir <- doesDirectoryExist absolute + when (not isDir) $ do + hPutStrLn stderr $ "Path \"" ++ absolute ++ "\" does not exist." + exitFailure + ds <- getDirectoryContents absolute >>= return . map (p ) + let ps = filter (isSuffixOf ".0rp") ds + let xs = filter (isSuffixOf ".0rx") ds + let ts = filter (isSuffixOf ".0rt") ds + return (ps,xs,ts) + +getRealPathsForDeps :: [CompileMetadata] -> [String] +getRealPathsForDeps = map cmPath + +getSourceFilesForDeps :: [CompileMetadata] -> [String] +getSourceFilesForDeps = concat . map extract where + extract m = map (cmPath m ) (cmPublicFiles m) + +getRequiresFromDeps :: [CompileMetadata] -> [CategoryIdentifier] +getRequiresFromDeps = concat . map cmExtraRequires + +getNamespacesForDeps :: [CompileMetadata] -> [String] +getNamespacesForDeps = filter (not . null) . map cmNamespace + +getIncludePathsForDeps :: [CompileMetadata] -> [String] +getIncludePathsForDeps = concat . map cmSubdirs + +getObjectFilesForDeps :: [CompileMetadata] -> [ObjectFile] +getObjectFilesForDeps = concat . map cmObjectFiles + +loadPublicDeps :: [String] -> IO (Bool,[CompileMetadata]) +loadPublicDeps = loadDepsCommon False cmPublicDeps + +loadPrivateDeps :: [CompileMetadata] -> IO (Bool,[CompileMetadata]) +loadPrivateDeps ms = do + (fr,new) <- loadDepsCommon False (\m -> cmPublicDeps m ++ cmPrivateDeps m) toFind + return (fr,ms ++ existing ++ new) where + paths = concat $ map (\m -> cmPublicDeps m ++ cmPrivateDeps m) ms + (existing,toFind) = foldl splitByExisting ([],[]) $ nub paths + byPath = Map.fromList $ map (\m -> (cmPath m,m)) ms + splitByExisting (es,fs) p = + case p `Map.lookup` byPath of + Just m -> (es ++ [m],fs) + Nothing -> (es,fs ++ [p]) + +loadDepsCommon :: Bool -> (CompileMetadata -> [String]) -> [String] -> IO (Bool,[CompileMetadata]) +loadDepsCommon s f ps = fmap snd $ fixedPaths >>= collect (Set.empty,(True,[])) where + fixedPaths = sequence $ map canonicalizePath ps + collect xa@(pa,(fr,xs)) (p:ps) + | p `Set.member` pa = collect xa ps + | otherwise = do + when (not s) $ hPutStrLn stderr $ "Loading metadata for dependency \"" ++ p ++ "\"." + m <- loadMetadata p + fresh <- checkModuleFreshness p m + when (not s && not fresh) $ + hPutStrLn stderr $ "Module \"" ++ p ++ "\" is out of date and should be recompiled." + collect (p `Set.insert` pa,(fresh && fr,xs ++ [m])) (ps ++ f m) + collect xa _ = return xa + +fixPath :: String -> String +fixPath = foldl () "" . process [] . map dropSlash . splitPath where + dropSlash "/" = "/" + dropSlash d + | isSuffixOf "/" d = reverse $ tail $ reverse d + | otherwise = d + process rs (".":ds) = process rs ds + process ("..":rs) ("..":ds) = process ("..":"..":rs) ds + process ("/":[]) ("..":ds) = process ("/":[]) ds + process (_:rs) ("..":ds) = process rs ds + process rs (d:ds) = process (d:rs) ds + process rs _ = reverse rs + +sortCompiledFiles :: [String] -> ([String],[String],[String]) +sortCompiledFiles = foldl split ([],[],[]) where + split fs@(hxx,cxx,os) f + | isSuffixOf ".hpp" f = (hxx++[f],cxx,os) + | isSuffixOf ".h" f = (hxx++[f],cxx,os) + | isSuffixOf ".cpp" f = (hxx,cxx++[f],os) + | isSuffixOf ".cc" f = (hxx,cxx++[f],os) + | isSuffixOf ".a" f = (hxx,cxx,os++[f]) + | isSuffixOf ".o" f = (hxx,cxx,os++[f]) + | otherwise = fs + +checkModuleFreshness :: String -> CompileMetadata -> IO Bool +checkModuleFreshness p (CompileMetadata p2 _ is is2 _ _ _ ps xs ts hxx cxx _) = do + time <- getModificationTime $ getCachedPath p "" metadataFilename + (ps2,xs2,ts2) <- findSourceFiles p "" + let e1 = checkMissing ps ps2 + let e2 = checkMissing xs xs2 + let e3 = checkMissing ts ts2 + rm <- check time (p recompileFilename) + f1 <- sequence $ map (\p2 -> check time $ getCachedPath p2 "" metadataFilename) $ is ++ is2 + f2 <- sequence $ map (check time . (p2 )) $ ps ++ xs + f3 <- sequence $ map (check time . getCachedPath p2 "") $ hxx ++ cxx + let fresh = not $ any id $ [rm,e1,e2,e3] ++ f1 ++ f2 ++ f3 + return fresh where + check time f = do + exists <- doesPathExist f + if not exists + then return True + else do + time2 <- getModificationTime f + return (time2 > time) + checkMissing s0 s1 = not $ null $ (Set.fromList s1) `Set.difference` (Set.fromList s0) + +getObjectFileResolver :: [CategoryIdentifier] -> [ObjectFile] -> [Namespace] -> [CategoryName] -> [String] +getObjectFileResolver ce os ns ds = resolved ++ nonCategories where + categories = filter isCategoryObjectFile os + nonCategories = map oofFile $ filter (not . isCategoryObjectFile) os + categoryMap = Map.fromList $ map keyByCategory categories + keyByCategory o = ((ciCategory $ cofCategory o,ciNamespace $ cofCategory o),o) + objectMap = Map.fromList $ map keyBySpec categories + keyBySpec o = (cofCategory o,o) + directDeps = concat $ map (resolveDep . show) ds + directResolved = map cofCategory directDeps ++ ce + resolveDep d = unwrap $ foldl (<|>) Nothing allChecks <|> Just [] where + allChecks = map (\n -> (d,n) `Map.lookup` categoryMap >>= return . (:[])) (map show ns ++ [""]) + unwrap (Just xs) = xs + unwrap _ = [] + resolved = reverse $ nub $ reverse $ collectAll Set.empty directResolved + collectAll ca = concat . map (collect ca) + -- NOTE: Object files are collected with deps following things that depend on + -- them, without skipping over deps that have already been seen. This is so + -- that a dep strictly follows everything that depends on it. This is + -- is necessary when linking .a files. + collect ca c + | c `Set.member` ca = [] + | otherwise = + case c `Map.lookup` objectMap of + Just (CategoryObjectFile _ ds fs) -> fs ++ collectAll (c `Set.insert` ca) ds + Nothing -> [] + +resolveObjectDeps :: String -> [([String],CxxOutput)] -> [CompileMetadata] -> [ObjectFile] +resolveObjectDeps p os deps = resolvedCategories ++ nonCategories where + categories = filter (isJust . coCategory . snd) os + publicNamespaces = getNamespacesForDeps deps + nonCategories = map OtherObjectFile $ concat $ map fst $ filter (not . isJust . coCategory . snd) os + resolvedCategories = Map.elems $ Map.fromListWith mergeObjectFiles $ map resolveCategory categories + categoryMap = Map.fromList $ directCategories ++ depCategories + directCategories = map (keyByCategory . cxxToId) $ map snd categories + depCategories = map keyByCategory $ concat $ map categoriesToIds deps + categoriesToIds dep = map (\c -> CategoryIdentifier (cmPath dep) c (cmNamespace dep)) (cmCategories dep) + cxxToId (CxxOutput (Just c) _ ns _ _ _) = CategoryIdentifier p (show c) (show ns) + resolveCategory (fs,ca@(CxxOutput _ _ _ ns2 ds _)) = + (cxxToId ca,CategoryObjectFile (cxxToId ca) rs fs) where + rs = concat $ map (resolveDep categoryMap (map show ns2 ++ publicNamespaces) . show) ds + +resolveCategoryDeps :: [String] -> [CompileMetadata] -> [CategoryIdentifier] +resolveCategoryDeps cs deps = resolvedCategories where + publicNamespaces = getNamespacesForDeps deps + resolvedCategories = concat $ map (resolveDep categoryMap publicNamespaces) cs + categoryMap = Map.fromList depCategories + depCategories = map (keyByCategory . cofCategory) $ filter isCategoryObjectFile $ concat $ map cmObjectFiles deps + +keyByCategory :: CategoryIdentifier -> ((String,String),CategoryIdentifier) +keyByCategory c = ((ciCategory c,ciNamespace c),c) + +resolveDep :: Map.Map (String,String) CategoryIdentifier -> [String] -> String -> [CategoryIdentifier] +resolveDep cm ns d = unwrap $ foldl (<|>) Nothing allChecks where + allChecks = map (\n -> (d,n) `Map.lookup` cm >>= return . (:[])) ns + unwrap (Just xs) = xs + unwrap _ = [UnresolvedCategory d] diff --git a/src/Cli/CompileOptions.hs b/src/Cli/CompileOptions.hs new file mode 100644 --- /dev/null +++ b/src/Cli/CompileOptions.hs @@ -0,0 +1,106 @@ +{- ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Cli.CompileOptions ( + CompileOptions(..), + CompileMode(..), + ForceMode(..), + HelpMode(..), + emptyCompileOptions, + isCompileBinary, + isCompileIncremental, + isCompileRecompile, + isCreateTemplates, + isExecuteTests, + isOnlyShowPath, + maybeDisableHelp, +) where + + +data CompileOptions = + CompileOptions { + coHelp :: HelpMode, + coPublicDeps :: [String], + coPrivateDeps :: [String], + coSources :: [String], + coExtraFiles :: [String], + coExtraPaths :: [String], + coExtraRequires :: [String], + coSourcePrefix :: String, + coMode :: CompileMode, + coOutputName :: String, + coForce :: ForceMode + } deriving (Show) + +emptyCompileOptions :: CompileOptions +emptyCompileOptions = + CompileOptions { + coHelp = HelpUnspecified, + coPublicDeps = [], + coPrivateDeps = [], + coSources = [], + coExtraFiles = [], + coExtraPaths = [], + coExtraRequires = [], + coSourcePrefix = "", + coMode = CompileUnspecified, + coOutputName = "", + coForce = DoNotForce + } + +data HelpMode = HelpNeeded | HelpNotNeeded | HelpUnspecified deriving (Eq,Show) + +data ForceMode = DoNotForce | AllowRecompile | ForceRecompile | ForceAll deriving (Eq,Ord,Show) + +data CompileMode = + OnlyShowPath | + CompileBinary { + cbCategory :: String, + cbFunction :: String + } | + ExecuteTests { + etInclude :: [String] + } | + CompileIncremental | + CompileRecompile | + CreateTemplates | + CompileUnspecified + deriving (Eq,Read,Show) + +isOnlyShowPath OnlyShowPath = True +isOnlyShowPath _ = False + +isCompileBinary (CompileBinary _ _) = True +isCompileBinary _ = False + +isCompileIncremental CompileIncremental = True +isCompileIncremental _ = False + +isCompileRecompile CompileRecompile = True +isCompileRecompile _ = False + +isExecuteTests (ExecuteTests _) = True +isExecuteTests _ = False + +isCreateTemplates CreateTemplates = True +isCreateTemplates _ = False + +maybeDisableHelp HelpUnspecified = HelpNotNeeded +maybeDisableHelp h = h diff --git a/src/Cli/Compiler.hs b/src/Cli/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Cli/Compiler.hs @@ -0,0 +1,395 @@ +{- ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +module Cli.Compiler ( + rootPath, + runCompiler, +) where + +import Control.Applicative ((<|>)) +import Control.Monad (when) +import Data.List (intercalate,isSuffixOf,nub,sort) +import Data.Maybe (isJust) +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.Posix.Temp (mkstemps) +import System.IO +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Base.CompileError +import Base.Mergeable +import Cli.CompileMetadata +import Cli.CompileOptions +import Cli.ParseCompileOptions -- Not safe, due to Text.Regex.TDFA. +import Cli.TestRunner +import Compilation.CompileInfo +import CompilerCxx.Category +import CompilerCxx.Naming +import Config.LoadConfig +import Config.Paths +import Config.Programs +import Parser.SourceFile +import Types.Builtin +import Types.DefinedCategory +import Types.TypeCategory +import Types.TypeInstance + +import Paths_zeolite_lang (getDataFileName) + + +rootPath :: IO FilePath +rootPath = getDataFileName "" + +runCompiler :: CompileOptions -> IO () +runCompiler (CompileOptions _ _ _ _ _ _ _ _ OnlyShowPath _ _) = do + p <- rootPath >>= canonicalizePath + hPutStrLn stdout p +runCompiler co@(CompileOptions _ _ _ ds _ _ _ p (ExecuteTests tp) _ f) = do + (backend,resolver) <- loadConfig + ds' <- sequence $ map (preloadModule resolver) ds + let possibleTests = Set.fromList $ concat $ map getTestsFromPreload ds' + case Set.toList $ allowTests `Set.difference` possibleTests of + [] -> return () + ts -> do + hPutStr stderr $ "Some test files do not occur in the selected modules: " ++ + intercalate ", " (map show ts) ++ "\n" + exitFailure + allResults <- fmap concat $ sequence $ map (runTests backend) ds' + let passed = sum $ map (fst . fst) allResults + let failed = sum $ map (snd . fst) allResults + processResults passed failed (mergeAllM $ map snd allResults) where + preloadModule r d = do + m <- loadMetadata (p d) + base <- resolveBaseModule r + (fr1,deps1) <- loadPublicDeps [base,p d] + checkAllowedStale fr1 f + (fr2,deps2) <- loadPrivateDeps deps1 + checkAllowedStale fr2 f + return (d,m,deps1,deps2) + getTestsFromPreload (_,m,_,_) = cmTestFiles m + allowTests = Set.fromList tp + isTestAllowed t = if null allowTests then True else t `Set.member` allowTests + runTests :: CompilerBackend b => b -> + (String,CompileMetadata,[CompileMetadata],[CompileMetadata]) -> + IO [((Int,Int),CompileInfo ())] + runTests b (d,m,deps1,deps2) = do + let paths = getIncludePathsForDeps deps1 + let ss = fixPaths $ getSourceFilesForDeps deps1 + let os = getObjectFilesForDeps deps2 + ss' <- zipWithContents p ss + ts' <- zipWithContents p (map (d ) $ filter isTestAllowed $ cmTestFiles m) + tm <- return $ do + cs <- fmap concat $ collectAllOrErrorM $ map parsePublicSource ss' + includeNewTypes defaultCategories cs + if isCompileError tm + then return [((0,0),tm >> return ())] + else sequence $ map (runSingleTest b paths (m:deps1) os (getCompileSuccess tm)) ts' + processResults passed failed rs + | isCompileError rs = do + hPutStr stderr $ "\nTest errors:\n" ++ (show $ getCompileError rs) + hPutStrLn stderr $ "\nPassed: " ++ show passed ++ " test(s), Failed: " ++ show failed ++ " test(s)" + hPutStrLn stderr $ "Zeolite tests failed." + exitFailure + | otherwise = do + hPutStrLn stderr $ "\nPassed: " ++ show passed ++ " test(s), Failed: " ++ show failed ++ " test(s)" + hPutStrLn stderr $ "Zeolite tests passed." +runCompiler co@(CompileOptions h _ _ ds _ _ _ p CompileRecompile _ f) = do + fmap mergeAll $ sequence $ map recompileSingle ds where + recompileSingle d0 = do + let d = p d0 + rm <- tryLoadRecompile d + upToDate <- isPathUpToDate d + maybeCompile rm upToDate where + maybeCompile Nothing _ = do + hPutStrLn stderr $ "Path " ++ d0 ++ " has not been configured or compiled yet." + exitFailure + maybeCompile (Just rm') upToDate + | f < ForceAll && upToDate = hPutStrLn stderr $ "Path " ++ d0 ++ " is up to date." + | otherwise = do + let (RecompileMetadata p d is is2 es ep ec m o) = rm' + -- In case the module is manually configured with a p such as "..", + -- since the absolute path might not be known ahead of time. + absolute <- canonicalizePath d0 + let fixed = fixPath (absolute p) + let recompile = CompileOptions { + coHelp = h, + coPublicDeps = map ((fixed d) ) is, + coPrivateDeps = map ((fixed d) ) is2, + coSources = [d], + coExtraFiles = es, + coExtraPaths = ep, + coExtraRequires = ec, + coSourcePrefix = fixed, + coMode = m, + coOutputName = o, + coForce = if f == ForceAll then ForceRecompile else AllowRecompile + } + runCompiler recompile +runCompiler co@(CompileOptions h is is2 ds es ep ec p m o f) = do + (backend,resolver) <- loadConfig + as <- fmap fixPaths $ sequence $ map (resolveModule resolver p) is + as2 <- fmap fixPaths $ sequence $ map (resolveModule resolver p) is2 + (fr,deps) <- loadPublicDeps (as ++ as2) + checkAllowedStale fr f + if isCreateTemplates m + then sequence_ $ map (processTemplates deps) ds + else do + ma <- sequence $ map (processPath backend resolver deps as as2) ds + let ms = concat $ map snd ma + let deps2 = map fst ma + createBinary backend resolver (deps ++ deps2) m ms + hPutStrLn stderr $ "Zeolite compilation succeeded." where + ep' = fixPaths $ map (p ) ep + es' = fixPaths $ map (p ) es + processPath b r deps as as2 d = do + isConfigured <- isPathConfigured d + when (isConfigured && f == DoNotForce) $ do + hPutStrLn stderr $ "Module " ++ d ++ " has already been configured. " ++ + "Recompile with -r or use -f to overwrite the config." + exitFailure + eraseCachedData (p d) + absolute <- canonicalizePath p + let rm = RecompileMetadata { + rmRoot = absolute, + rmPath = d, + rmPublicDeps = as, + rmPrivateDeps = as2, + rmExtraFiles = sort es, + rmExtraPaths = sort ep, + rmExtraRequires = sort ec, + rmMode = m, + rmOutputName = o + } + when (f == DoNotForce || f == ForceAll) $ writeRecompile (p d) rm + (ps,xs,ts) <- findSourceFiles p d + base <- resolveBaseModule r + actual <- resolveModule r p d + isBase <- isBaseModule r actual + -- Lazy dependency loading, in case we're compiling base. + deps2 <- if isBase + then return deps + else do + (fr,bpDeps) <- loadPublicDeps [base] + checkAllowedStale fr f + return $ bpDeps ++ deps + let ss = fixPaths $ getSourceFilesForDeps deps2 + ss' <- zipWithContents p ss + let paths = getIncludePathsForDeps deps2 + ps' <- zipWithContents p ps + xs' <- zipWithContents p xs + ns0 <- canonicalizePath (p d) >>= return . StaticNamespace . publicNamespace + let ns2 = map StaticNamespace $ filter (not . null) $ getNamespacesForDeps deps + let fs = compileAll ns0 ns2 ss' ps' xs' + writeOutput b r paths ns0 deps2 d as as2 + (map takeFileName ps) + (map takeFileName xs) + (map takeFileName ts) fs + writeOutput b r paths ns0 deps d as as2 ps xs ts fs + | isCompileError fs = do + formatWarnings fs + hPutStr stderr $ "Compiler errors:\n" ++ (show $ getCompileError fs) + hPutStrLn stderr $ "Zeolite compilation failed." + exitFailure + | otherwise = do + formatWarnings fs + let (pc,mf,fs') = getCompileSuccess fs + let ss = map (\ns -> getCachedPath (p d) ns "") $ nub $ filter (not . null) $ map show $ [ns0] ++ map coNamespace fs' + let paths' = paths ++ ep' ++ ss + let hxx = filter (isSuffixOf ".hpp" . coFilename) fs' + let other = filter (not . isSuffixOf ".hpp" . coFilename) fs' + os1 <- sequence $ map (writeOutputFile b (show ns0) paths' d) $ hxx ++ other + base <- resolveBaseModule r + actual <- resolveModule r p d + isBase <- isBaseModule r actual + -- Base files should be compiled to .o and not .a. + let extraComp = if isBase + then compileBuiltinFile + else compileExtraFile + os2 <- fmap concat $ sequence $ map (extraComp b (show ns0) paths' d) es' + let (hxx,cxx,os') = sortCompiledFiles $ map (\f -> show (coNamespace f) coFilename f) fs' ++ es' + path <- canonicalizePath $ p d + let os1' = resolveObjectDeps path os1 deps + let cm0 = CompileMetadata { + cmPath = path, + cmNamespace = show ns0, + cmPublicDeps = as, + cmPrivateDeps = as2, + cmExtraRequires = [], + cmCategories = sort $ map show pc, + cmSubdirs = sort $ ss ++ ep', + cmPublicFiles = sort ps, + cmPrivateFiles = sort xs, + cmTestFiles = sort ts, + cmHxxFiles = sort hxx, + cmCxxFiles = sort cxx, + cmObjectFiles = os1' ++ os2 ++ map OtherObjectFile os' + } + let ec' = resolveCategoryDeps ec (cm0:deps) + let cm = CompileMetadata { + cmPath = cmPath cm0, + cmNamespace = cmNamespace cm0, + cmPublicDeps = cmPublicDeps cm0, + cmPrivateDeps = cmPrivateDeps cm0, + cmExtraRequires = ec', + cmCategories = cmCategories cm0, + cmSubdirs = cmSubdirs cm0, + cmPublicFiles = cmPublicFiles cm0, + cmPrivateFiles = cmPrivateFiles cm0, + cmTestFiles = cmTestFiles cm0, + cmHxxFiles = cmHxxFiles cm0, + cmCxxFiles = cmCxxFiles cm0, + cmObjectFiles = cmObjectFiles cm0 + } + when (not $ isCreateTemplates m) $ writeMetadata (p d) cm + return (cm,mf) + formatWarnings c + | null $ getCompileWarnings c = return () + | otherwise = hPutStr stderr $ "Compiler warnings:\n" ++ (concat $ map (++ "\n") (getCompileWarnings c)) + writeOutputFile b ns0 paths d ca@(CxxOutput c f ns ns2 req content) = do + hPutStrLn stderr $ "Writing file " ++ f + writeCachedFile (p d) (show ns) f $ concat $ map (++ "\n") content + if isSuffixOf ".cpp" f || isSuffixOf ".cc" f + then do + let f' = getCachedPath (p d) (show ns) f + let p0 = getCachedPath (p d) "" "" + let p1 = getCachedPath (p d) (show ns) "" + createCachePath (p d) + let ns' = if isStaticNamespace ns then show ns else show ns0 + let command = CompileToObject f' (getCachedPath (p d) ns' "") dynamicNamespaceName "" (p0:p1:paths) False + o <- runCxxCommand b command + return $ ([o],ca) + else return ([],ca) + compileExtraFile = compileExtraCommon True + compileBuiltinFile = compileExtraCommon False + compileExtraCommon e b ns0 paths d f + | isSuffixOf ".cpp" f || isSuffixOf ".cc" f = do + let f' = p d f + createCachePath (p d) + let command = CompileToObject f' (getCachedPath (p d) "" "") dynamicNamespaceName ns0 paths e + o <- runCxxCommand b command + return [OtherObjectFile o] + | otherwise = return [] + processTemplates deps d = do + (ps,xs,_) <- findSourceFiles p d + ps' <- zipWithContents p ps + xs' <- zipWithContents p xs + let ss = fixPaths $ getSourceFilesForDeps deps + ss' <- zipWithContents p ss + let ts = createTemplates ss' ps' xs' :: CompileInfo [CxxOutput] + if isCompileError ts + then do + formatWarnings ts + hPutStr stderr $ "Compiler errors:\n" ++ (show $ getCompileError ts) + hPutStrLn stderr $ "Zeolite compilation failed." + exitFailure + else do + formatWarnings ts + sequence $ map (writeTemplate d) $ getCompileSuccess ts + createTemplates is cs ds = do + tm1 <- addIncludes defaultCategories is + cs' <- fmap concat $ collectAllOrErrorM $ map parsePublicSource cs + let cs'' = map (setCategoryNamespace DynamicNamespace) cs' + tm2 <- includeNewTypes tm1 cs'' + da <- collectAllOrErrorM $ map parseInternalSource ds + let ds' = concat $ map snd da + let cs2 = concat $ map fst da + tm3 <- includeNewTypes tm2 cs2 + let ca = Set.fromList $ map getCategoryName $ filter isValueConcrete cs' + let ca' = foldr Set.delete ca $ map dcName ds' + collectAllOrErrorM $ map (compileConcreteTemplate tm3) $ Set.toList ca' + writeTemplate d (CxxOutput _ n _ _ _ content) = do + let n' = p d n + exists <- doesPathExist n' + if exists && f /= ForceAll + then hPutStrLn stderr $ "Skipping existing file " ++ n + else do + hPutStrLn stderr $ "Writing file " ++ n + writeFile n' $ concat $ map (++ "\n") content + compileAll ns0 ns2 is cs ds = do + tm1 <- addIncludes defaultCategories is + cs' <- fmap concat $ collectAllOrErrorM $ map parsePublicSource cs + let cs'' = map (setCategoryNamespace ns0) cs' + xa <- collectAllOrErrorM $ map parsePrivate ds + let cm = CategoryModule { + cnBase = tm1, + cnNamespaces = ns0:ns2, + cnPublic = cs'', + cnPrivate = xa + } + xx <- compileCategoryModule cm + let pc = map getCategoryName cs'' + ms <- maybeCreateMain cm m + return (pc,ms,xx) + parsePrivate d = do + let ns1 = StaticNamespace $ privateNamespace (p fst d) + (cs,ds) <- parseInternalSource d + let cs' = map (setCategoryNamespace ns1) cs + return $ PrivateSource ns1 cs' ds + addIncludes tm fs = do + cs <- fmap concat $ collectAllOrErrorM $ map parsePublicSource fs + includeNewTypes tm cs + mergeInternal ds = (concat $ map fst ds,concat $ map snd ds) + getBinaryName (CompileBinary n _) = canonicalizePath $ if null o then n else o + getBinaryName _ = return "" + createBinary b r deps ma@(CompileBinary n _) ms + | length ms > 1 = do + hPutStrLn stderr $ "Multiple matches for main category " ++ n ++ "." + exitFailure + | length ms == 0 = do + hPutStrLn stderr $ "Main category " ++ n ++ " not found." + exitFailure + | otherwise = do + f0 <- getBinaryName ma + let f0 = if null o then n else o + let (CxxOutput _ _ _ ns2 req content) = head ms + -- TODO: Create a helper or a constant or something. + (o',h) <- mkstemps "/tmp/zmain_" ".cpp" + hPutStr h $ concat $ map (++ "\n") content + hClose h + base <- resolveBaseModule r + (_,bpDeps) <- loadPublicDeps [base] + (_,deps2) <- loadPrivateDeps (bpDeps ++ deps) + let paths = fixPaths $ getIncludePathsForDeps deps2 + let os = getObjectFilesForDeps deps2 + let req2 = getRequiresFromDeps deps2 + let ofr = getObjectFileResolver req2 os + let os' = ofr ns2 req + let command = CompileToBinary o' os' f0 paths + hPutStrLn stderr $ "Creating binary " ++ f0 + runCxxCommand b command + removeFile o' + createBinary _ _ _ _ _ = return () + maybeCreateMain cm (CompileBinary n f) = + fmap (:[]) $ compileModuleMain cm (CategoryName n) (FunctionName f) + maybeCreateMain _ _ = return [] + +checkAllowedStale :: Bool -> ForceMode -> IO () +checkAllowedStale fr f = do + when (not fr && f < ForceRecompile) $ do + hPutStrLn stderr $ "Some dependencies are out of date. " ++ + "Recompile them or use -f to force." + exitFailure + +fixPaths :: [String] -> [String] +fixPaths = nub . map fixPath + +zipWithContents :: String -> [String] -> IO [(String,String)] +zipWithContents p fs = fmap (zip $ map fixPath fs) $ sequence $ map (readFile . (p )) fs diff --git a/src/Cli/ParseCompileOptions.hs b/src/Cli/ParseCompileOptions.hs new file mode 100644 --- /dev/null +++ b/src/Cli/ParseCompileOptions.hs @@ -0,0 +1,237 @@ +{- ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +module Cli.ParseCompileOptions ( + optionHelpText, + parseCompileOptions, + validateCompileOptions, +) where + +import Control.Monad (when) +import Data.List (intercalate,isSuffixOf) +import System.FilePath (takeExtension) +import Text.Regex.TDFA -- Not safe! + +import Base.CompileError +import Cli.CompileMetadata (allowedExtraTypes,getCacheRelativePath) +import Cli.CompileOptions + + +optionHelpText :: [String] +optionHelpText = [ + "", + "zeolite [options...] -m [category(.function)] -o [binary] [path]", + "zeolite [options...] -c [paths...]", + "zeolite [options...] -r [paths...]", + "zeolite [options...] -t [paths...]", + "zeolite [options...] --templates [paths...]", + "zeolite [options...] --get-path", + "", + "Modes:", + " -c: Only compile the individual files. (default)", + " -m [category(.function)]: Create a binary that executes the function.", + " -r: Recompile using the previous compilation options.", + " -t: Only execute tests, without other compilation.", + " --templates: Only create C++ templates for undefined categories in .0rp sources.", + " --get-path: Show the data path and immediately exit.", + "", + "Options:", + " -e [path|file]: Include an extra source file or path during compilation.", + " -f: Force compilation instead of recompiling with -r.", + " -i [path]: A single source path to include as a *public* dependency.", + " -I [path]: A single source path to include as a *private* dependency.", + " -o [binary]: The name of the binary file to create with -m.", + " -p [path]: Set a path prefix for finding the specified source files.", + "", + "[category]: The name of a concrete category with no params.", + "[function]: The name of a @type function (defaults to \"run\") with no args or params.", + "[path(s...)]: Path(s) containing source or dependency files.", + "" + ] + +defaultMainFunc :: String +defaultMainFunc = "run" + +parseCompileOptions :: CompileErrorM m => [String] -> m CompileOptions +parseCompileOptions = parseAll emptyCompileOptions . zip [1..] where + parseAll co [] = return co + parseAll co os = do + (os',co') <- parseSingle co os + parseAll co' os' + argError n o m = compileError $ "Argument " ++ show n ++ " (\"" ++ o ++ "\"): " ++ m + checkPathName n f o + | f =~ "^(/[^/]+|[^-/][^/]*)(/[^/]+)*$" = return () + | null o = argError n f "Invalid file path." + | otherwise = argError n f $ "Invalid file path for " ++ o ++ "." + checkCategoryName n c o + | c =~ "^[A-Z][A-Za-z0-9]+$" = return () + | null o = argError n c "Invalid category name." + | otherwise = argError n c $ "Invalid category name for " ++ o ++ "." + checkFunctionName n d o + | d =~ "^[a-z][A-Za-z0-9]+$" = return () + | null d = argError n d "Invalid function name." + | otherwise = argError n d $ "Invalid function name for " ++ o ++ "." + + parseSingle (CompileOptions _ is is2 ds es ep ec p m o f) ((n,"-h"):os) = + return (os,CompileOptions HelpNeeded is is2 ds es ep ec p m o f) + + parseSingle (CompileOptions h is is2 ds es ep ec p m o _) ((n,"-f"):os) = + return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep ec p m o ForceAll) + + parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"-c"):os) + | m /= CompileUnspecified = argError n "-c" "Compiler mode already set." + | otherwise = return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep ec p CompileIncremental o f) + + parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"-r"):os) + | m /= CompileUnspecified = argError n "-r" "Compiler mode already set." + | otherwise = return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep ec p CompileRecompile o f) + + parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"-t"):os) + | m /= CompileUnspecified = argError n "-t" "Compiler mode already set." + | otherwise = return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep ec p (ExecuteTests []) o f) + + parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"--templates"):os) + | m /= CompileUnspecified = argError n "-t" "Compiler mode already set." + | otherwise = return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep ec p CreateTemplates o f) + + parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"--get-path"):os) + | m /= CompileUnspecified = argError n "-t" "Compiler mode already set." + | otherwise = return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep ec p OnlyShowPath o f) + + parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"-m"):os) + | m /= CompileUnspecified = argError n "-m" "Compiler mode already set." + | otherwise = update os where + update ((n,c):os) = do + let (t,fn) = check $ break (== '.') c + checkCategoryName n t "-m" + checkFunctionName n fn "-m" + return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep ec p (CompileBinary t fn) o f) where + check (t,"") = (t,defaultMainFunc) + check (t,'.':fn) = (t,fn) + update _ = argError n "-m" "Requires a category name." + + parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"-o"):os) + | not $ null o = argError n "-o" "Output name already set." + | otherwise = update os where + update ((n,o):os) = do + checkPathName n o "-o" + return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep ec p m o f) + update _ = argError n "-o" "Requires an output name." + + parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"-i"):os) = update os where + update ((n,d):os) + | isSuffixOf ".0rp" d = argError n d "Cannot directly include .0rp source files." + | isSuffixOf ".0rx" d = argError n d "Cannot directly include .0rx source files." + | isSuffixOf ".0rt" d = argError n d "Cannot directly include .0rt test files." + | otherwise = do + checkPathName n d "-i" + return (os,CompileOptions (maybeDisableHelp h) (is ++ [d]) is2 ds es ep ec p m o f) + update _ = argError n "-i" "Requires a source path." + + parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"-I"):os) = update os where + update ((n,d):os) + | isSuffixOf ".0rp" d = argError n d "Cannot directly include .0rp source files." + | isSuffixOf ".0rx" d = argError n d "Cannot directly include .0rx source files." + | isSuffixOf ".0rt" d = argError n d "Cannot directly include .0rt test files." + | otherwise = do + checkPathName n d "-i" + return (os,CompileOptions (maybeDisableHelp h) is (is2 ++ [d]) ds es ep ec p m o f) + update _ = argError n "-I" "Requires a source path." + + parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"-e"):os) = update os where + update ((n,e):os) + | any (flip isSuffixOf e) allowedExtraTypes = do + checkPathName n e "-e" + return (os,CompileOptions (maybeDisableHelp h) is is2 ds (es ++ [e]) ep ec p m o f) + | takeExtension e == "" || e == "." = do + checkPathName n e "-e" + return (os,CompileOptions (maybeDisableHelp h) is is2 ds es (ep ++ [e]) ec p m o f) + | otherwise = argError n "-e" $ "Only " ++ intercalate ", " allowedExtraTypes ++ + " and directory sources are allowed." + update _ = argError n "-e" "Requires a source filename." + + parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"-p"):os) + | not $ null p = argError n "-p" "Path prefix already set." + | otherwise = update os where + update ((n,p):os) = do + checkPathName n p "-p" + return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep ec p m o f) + update _ = argError n "-p" "Requires a path prefix." + + parseSingle _ ((n,o@('-':_)):os) = argError n o "Unknown option." + + parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,d):os) + | isSuffixOf ".0rp" d = argError n d "Cannot directly include .0rp source files." + | isSuffixOf ".0rx" d = argError n d "Cannot directly include .0rx source files." + | isSuffixOf ".0rt" d = do + when (not $ isExecuteTests m) $ + argError n d "Test mode (-t) must be enabled before listing any .0rt test files." + checkPathName n d "" + let (ExecuteTests tp) = m + return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep ec p (ExecuteTests $ tp ++ [d]) o f) + | otherwise = do + checkPathName n d "" + return (os,CompileOptions (maybeDisableHelp h) is is2 (ds ++ [d]) es ep ec p m o f) + +validateCompileOptions :: CompileErrorM m => CompileOptions -> m CompileOptions +validateCompileOptions co@(CompileOptions h is is2 ds es ep ec p m o _) + | h /= HelpNotNeeded = return co + + | (not $ null o) && (isCompileIncremental m) = + compileError "Output filename (-o) is not allowed in compile-only mode (-c)." + + | (not $ null o) && (isExecuteTests m) = + compileError "Output filename (-o) is not allowed in test mode (-t)." + | (not $ null $ is ++ is2) && (isExecuteTests m) = + compileError "Include paths (-i/-I) are not allowed in test mode (-t)." + | (not $ null $ es ++ ep) && (isExecuteTests m) = + compileError "Extra files (-e) are not allowed in test mode (-t)." + + | (not $ null o) && (isCreateTemplates m) = + compileError "Output filename (-o) is not allowed in template mode (--templates)." + | (not $ null $ es ++ ep) && (isCreateTemplates m) = + compileError "Extra files (-e) are not allowed in template mode (--templates)." + + | (not $ null p) && (isCompileRecompile m) = + compileError "Path prefix (-p) is not allowed in recompile mode (-r)." + | (not $ null o) && (isCompileRecompile m) = + compileError "Output filename (-o) is not allowed in recompile mode (-r)." + | (not $ null $ is ++ is2) && (isCompileRecompile m) = + compileError "Include paths (-i/-I) are not allowed in recompile mode (-r)." + | (not $ null $ es ++ ep) && (isCompileRecompile m) = + compileError "Extra files (-e) are not allowed in recompile mode (-r)." + + | (not $ null p) && (isOnlyShowPath m) = + compileError "Path prefix (-p) is not allowed in path mode (---get-path)." + | (not $ null o) && (isOnlyShowPath m) = + compileError "Output filename (-o) is not allowed in path mode (---get-path)." + | (not $ null $ is ++ is2) && (isOnlyShowPath m) = + compileError "Include paths (-i/-I) are not allowed in path mode (---get-path)." + | (not $ null $ es ++ ep) && (isOnlyShowPath m) = + compileError "Extra files (-e) are not allowed in path mode (---get-path)." + | (not $ null ds) && (isOnlyShowPath m) = + compileError "Input paths are not allowed in path mode (---get-path)." + + | length ds > 1 && length (es ++ ep) > 0 = + compileError "Extra files and paths (-e) cannot be used with multiple input paths, to avoid ambiguity." + + | not (isOnlyShowPath m) && null ds = + compileError "Please specify at least one input path." + | (length ds /= 1) && (isCompileBinary m) = + compileError "Specify exactly one input path for binary mode (-m)." + | otherwise = return co diff --git a/src/Cli/TestRunner.hs b/src/Cli/TestRunner.hs new file mode 100644 --- /dev/null +++ b/src/Cli/TestRunner.hs @@ -0,0 +1,172 @@ +{- ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +module Cli.TestRunner ( + runSingleTest, +) where + +import Control.Arrow (second) +import Control.Monad (when) +import Data.List (isSuffixOf,nub) +import System.Directory (setCurrentDirectory) +import System.IO +import System.Posix.Temp (mkdtemp) +import System.FilePath +import Text.Parsec +import Text.Regex.TDFA -- Not safe! + +import Base.CompileError +import Base.Mergeable +import Cli.CompileMetadata +import Compilation.CompileInfo +import CompilerCxx.Category +import CompilerCxx.Naming +import Config.Programs +import Parser.SourceFile +import Types.Builtin +import Types.IntegrationTest +import Types.TypeCategory +import Types.TypeInstance + + +runSingleTest :: CompilerBackend b => b -> [String] -> [CompileMetadata] -> + [ObjectFile] -> CategoryMap SourcePos -> (String,String) -> + IO ((Int,Int),CompileInfo ()) +runSingleTest b paths deps os tm (f,s) = do + hPutStrLn stderr $ "\nExecuting tests from " ++ f + allResults <- checkAndRun (parseTestSource (f,s)) + return $ second (flip reviseError $ "\nIn test file " ++ f) allResults where + checkAndRun ts + | isCompileError ts = do + hPutStrLn stderr $ "Failed to parse tests in " ++ f + return ((0,1),ts >> return ()) + | otherwise = do + allResults <- sequence $ map runSingle $ getCompileSuccess ts + let passed = length $ filter (not . isCompileError) allResults + let failed = length $ filter isCompileError allResults + return ((passed,failed),mergeAllM allResults) + runSingle t = do + let name = ithTestName $ itHeader t + let context = formatFullContextBrace (ithContext $ itHeader t) + hPutStrLn stderr $ "\n*** Executing test \"" ++ name ++ "\" ***" + outcome <- fmap (flip reviseError ("\nIn test \"" ++ name ++ "\"" ++ context)) $ + run name (ithResult $ itHeader t) (itCategory t) (itDefinition t) + if isCompileError outcome + then hPutStrLn stderr $ "*** Test \"" ++ name ++ "\" failed ***" + else hPutStrLn stderr $ "*** Test \"" ++ name ++ "\" passed ***" + return outcome + + run n (ExpectCompileError _ rs es) cs ds = do + let result = compileAll Nothing cs ds :: CompileInfo ([CategoryName],[String],Namespace,[CxxOutput]) + if not $ isCompileError result + then return $ compileError "Expected compiler error" + else return $ do + let warnings = getCompileWarnings result + let errors = show $ getCompileError result + checkContent rs es (warnings ++ lines errors) [] [] + + run n (ExpectRuntimeError _ e rs es) cs ds = execute False n e rs es cs ds + run n (ExpectRuntimeSuccess _ e rs es) cs ds = execute True n e rs es cs ds + + checkContent rs es comp err out = do + let cr = checkRequired rs comp err out + let ce = checkExcluded es comp err out + let compError = if null comp + then return () + else (mergeAllM $ map compileError comp) `reviseError` "\nOutput from compiler:" + let errError = if null err + then return () + else (mergeAllM $ map compileError err) `reviseError` "\nOutput to stderr from test:" + let outError = if null out + then return () + else (mergeAllM $ map compileError out) `reviseError` "\nOutput to stdout from test:" + if isCompileError cr || isCompileError ce + then mergeAllM [cr,ce,compError,errError,outError] + else mergeAllM [cr,ce] + + execute s n e rs es cs ds = do + let result = compileAll (Just e) cs ds :: CompileInfo ([CategoryName],[String],Namespace,[CxxOutput]) + if isCompileError result + then return $ result >> return () + else do + let warnings = getCompileWarnings result + let (req,main,ns,fs) = getCompileSuccess result + binaryName <- createBinary main req [ns] fs + let command = TestCommand binaryName (takeDirectory binaryName) + (TestCommandResult s' out err) <- runTestCommand b command + case (s,s') of + (True,False) -> return $ mergeAllM $ map compileError $ warnings ++ err ++ out + (False,True) -> return $ compileError "Expected runtime failure" + _ -> return $ checkContent rs es warnings err out + + compileAll e cs ds = do + let ns0 = map (StaticNamespace . cmNamespace) deps + let ns1 = StaticNamespace $ privateNamespace s + let cs' = map (setCategoryNamespace ns1) cs + let cm = CategoryModule { + cnBase = tm, + cnNamespaces = ns0, + cnPublic = [], + cnPrivate = [PrivateSource { + psNamespace = ns1, + psCategory = cs', + psDefine = ds + }] + } + xx <- compileCategoryModule cm + tm' <- includeNewTypes tm cs' + (req,main) <- case e of + Just e -> createTestFile tm' e + Nothing -> return ([],[]) + return (req,main,ns1,xx) + + checkRequired rs comp err out = mergeAllM $ map (checkSubsetForRegex True comp err out) rs + checkExcluded es comp err out = mergeAllM $ map (checkSubsetForRegex False comp err out) es + checkSubsetForRegex expected comp err out (OutputPattern OutputAny r) = + checkForRegex expected (comp ++ err ++ out) r "compiler output or test output" + checkSubsetForRegex expected comp _ _ (OutputPattern OutputCompiler r) = + checkForRegex expected comp r "compiler output" + checkSubsetForRegex expected _ err _ (OutputPattern OutputStderr r) = + checkForRegex expected err r "test stderr" + checkSubsetForRegex expected _ _ out (OutputPattern OutputStdout r) = + checkForRegex expected out r "test stdout" + checkForRegex :: Bool -> [String] -> String -> String -> CompileInfo () + checkForRegex expected ms r n = do + let found = any (=~ r) ms + when (found && not expected) $ compileError $ "Pattern \"" ++ r ++ "\" present in " ++ n + when (not found && expected) $ compileError $ "Pattern \"" ++ r ++ "\" missing from " ++ n + createBinary c req ns fs = do + dir <- mkdtemp "/tmp/ztest_" + hPutStrLn stderr $ "Writing temporary files to " ++ dir + sources <- sequence $ map (writeSingleFile dir) fs + let sources' = resolveObjectDeps dir sources deps + let main = dir "testcase.cpp" + let binary = dir "testcase" + writeFile main $ concat $ map (++ "\n") c + let paths' = nub $ map fixPath (dir:paths) + let req2 = getRequiresFromDeps deps + let ofr = getObjectFileResolver req2 (sources' ++ os) + let os' = ofr ns req + let command = CompileToBinary main os' binary paths' + runCxxCommand b command + return binary + writeSingleFile d ca@(CxxOutput _ f _ _ _ content) = do + writeFile (d f) $ concat $ map (++ "\n") content + if isSuffixOf ".cpp" f + then return ([d f],ca) + else return ([],ca) diff --git a/src/Compilation/CompileInfo.hs b/src/Compilation/CompileInfo.hs new file mode 100644 --- /dev/null +++ b/src/Compilation/CompileInfo.hs @@ -0,0 +1,133 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} + +module Compilation.CompileInfo ( + CompileInfo, + CompileMessage, + getCompileError, + getCompileSuccess, + getCompileWarnings, +) where + +import Data.List (intercalate) + +#if MIN_VERSION_base(4,9,0) +import Control.Monad.Fail +#endif + +import Base.CompileError +import Base.Mergeable + + +data CompileMessage = + CompileMessage { + cmMessage :: String, + cmNested :: [CompileMessage] + } + +instance Show CompileMessage where + show = format "" where + format indent (CompileMessage [] ms) = + concat (map (format indent) ms) + format indent (CompileMessage m ms) = + (doIndent indent m) ++ "\n" ++ concat (map (format $ indent ++ " ") ms) + doIndent indent s = intercalate "\n" $ map (indent ++) $ lines s + +data CompileInfo a = + CompileFail { + cfWarnings :: [String], + cfErrors :: CompileMessage + } | + CompileSuccess { + csWarnings :: [String], + csData :: a + } + +getCompileError = cfErrors +getCompileSuccess = csData +getCompileWarnings (CompileFail w _) = w +getCompileWarnings (CompileSuccess w _) = w + + +instance Functor CompileInfo where + fmap f (CompileFail w e) = CompileFail w e -- Not the same a. + fmap f (CompileSuccess w d) = CompileSuccess w (f d) + +instance Applicative CompileInfo where + pure = CompileSuccess [] + (CompileFail w e) <*> _ = CompileFail w e -- Not the same a. + i <*> (CompileFail w e) = CompileFail (getCompileWarnings i ++ w) e -- Not the same a. + (CompileSuccess w1 f) <*> (CompileSuccess w2 d) = CompileSuccess (w1 ++ w2) (f d) + +instance Monad CompileInfo where + (CompileFail w e) >>= _ = CompileFail w e -- Not the same a. + (CompileSuccess w d) >>= f = prependWarning w $ f d + return = CompileSuccess [] + +prependWarning w (CompileSuccess w2 d) = CompileSuccess (w ++ w2) d +prependWarning w (CompileFail w2 e) = CompileFail (w ++ w2) e + +instance CompileErrorM CompileInfo where + compileErrorM = CompileFail [] . flip CompileMessage [] + isCompileErrorM (CompileFail _ _) = True + isCompileErrorM _ = False + collectAllOrErrorM = result . splitErrorsAndData where + result ([],xs,ws) = CompileSuccess ws xs + result (es,_,ws) = CompileFail ws $ CompileMessage "" es + collectOneOrErrorM = result . splitErrorsAndData where + result (_,x:_,ws) = CompileSuccess ws x + result ([],_,ws) = CompileFail ws $ CompileMessage "No choices found" [] + result (es,_,ws) = CompileFail ws $ CompileMessage "" es + reviseErrorM x@(CompileSuccess _ _) _ = x + reviseErrorM x@(CompileFail w (CompileMessage [] ms)) s = CompileFail w $ CompileMessage s ms + reviseErrorM x@(CompileFail w e) s = CompileFail w $ CompileMessage s [e] + compileWarningM w = CompileSuccess [w] () + +instance MergeableM CompileInfo where + mergeAnyM = result . splitErrorsAndData where + result (_,xs@(x:_),ws) = CompileSuccess ws $ mergeAny xs + result ([],_,ws) = CompileFail ws $ CompileMessage "No choices found" [] + result (es,_,ws) = CompileFail ws $ CompileMessage "" es + mergeAllM = result . splitErrorsAndData where + result ([],xs,ws) = CompileSuccess ws $ mergeAll xs + result (es,_,ws) = CompileFail ws $ CompileMessage "" es + (CompileSuccess w1 x) `mergeNestedM` (CompileSuccess w2 y) = CompileSuccess (w1 ++ w2) $ x `mergeNested` y + (CompileFail w1 e) `mergeNestedM` (CompileSuccess w2 _) = CompileFail (w1 ++ w2) e + (CompileSuccess w1 _) `mergeNestedM` (CompileFail w2 e) = CompileFail (w1 ++ w2) e + (CompileFail w1 e1) `mergeNestedM` (CompileFail w2 e2) = CompileFail (w1 ++ w2) $ e1 `nestMessages` e2 + +#if MIN_VERSION_base(4,9,0) +instance MonadFail CompileInfo where + fail = compileErrorM +#endif + +nestMessages (CompileMessage m1 ms1) (CompileMessage [] ms2) = + CompileMessage m1 (ms1 ++ ms2) +nestMessages (CompileMessage [] ms1) (CompileMessage m2 ms2) = + CompileMessage m2 (ms1 ++ ms2) +nestMessages (CompileMessage m1 ms1) ma@(CompileMessage _ _) = + CompileMessage m1 (ms1 ++ [ma]) + +splitErrorsAndData :: Foldable f => f (CompileInfo a) -> ([CompileMessage],[a],[String]) +splitErrorsAndData = foldr partition ([],[],[]) where + partition (CompileFail w e) (es,ds,ws) = (e:es,ds,w++ws) + partition (CompileSuccess w d) (es,ds,ws) = (es,d:ds,w++ws) diff --git a/src/Compilation/CompilerState.hs b/src/Compilation/CompilerState.hs new file mode 100644 --- /dev/null +++ b/src/Compilation/CompilerState.hs @@ -0,0 +1,257 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Compilation.CompilerState ( + CleanupSetup(..), + CompilerContext(..), + CompiledData(..), + CompilerState(..), + ExpressionType(..), + LoopSetup(..), + MemberValue(..), + ReturnVariable(..), + csAddVariable, + csAllFilters, + csCheckValueInit, + csCheckVariableInit, + csClearOutput, + csCurrentScope, + csGetCategoryFunction, + csGetCleanup, + csGetLoop, + csGetOutput, + csGetParamScope, + csGetTypeFunction, + csGetVariable, + csInheritReturns, + csIsUnreachable, + csPrimNamedReturns, + csPushCleanup, + csRegisterReturn, + csRequiresTypes, + csResolver, + csSameType, + csSetNoReturn, + csStartLoop, + csUpdateAssigned, + csWrite, + getCleanContext, + reviseErrorStateT, + runDataCompiler, +) where + +import Control.Monad.Trans (lift) +import Control.Monad.Trans.State (StateT(..),execStateT,get,mapStateT,put) +import Data.Monoid +import qualified Data.Set as Set + +import Base.CompileError +import Base.Mergeable +import Types.DefinedCategory +import Types.Function +import Types.Positional +import Types.Procedure +import Types.TypeCategory +import Types.TypeInstance + + +type CompilerState a m = StateT a m + +class Monad m => CompilerContext c m s a | a -> c s where + ccCurrentScope :: a -> m SymbolScope + ccResolver :: a -> m AnyTypeResolver + ccSameType :: a -> TypeInstance -> m Bool + ccAllFilters :: a -> m ParamFilters + ccGetParamScope :: a -> ParamName -> m SymbolScope + ccRequiresTypes :: a -> Set.Set CategoryName -> m a + ccGetRequired :: a -> m (Set.Set CategoryName) + ccGetCategoryFunction :: a -> [c] -> Maybe CategoryName -> FunctionName -> m (ScopedFunction c) + ccGetTypeFunction :: a -> [c] -> Maybe GeneralInstance -> FunctionName -> m (ScopedFunction c) + ccCheckValueInit :: a -> [c] -> TypeInstance -> ExpressionType -> Positional GeneralInstance -> m () + ccGetVariable :: a -> [c] -> VariableName -> m (VariableValue c) + ccAddVariable :: a -> [c] -> VariableName -> VariableValue c -> m a + ccCheckVariableInit :: a -> [c] -> VariableName -> m () + ccWrite :: a -> s -> m a + ccGetOutput :: a -> m s + ccClearOutput :: a -> m a + ccUpdateAssigned :: a -> VariableName -> m a + ccInheritReturns :: a -> [a] -> m a + ccRegisterReturn :: a -> [c] -> Maybe ExpressionType -> m a + ccPrimNamedReturns :: a -> m [ReturnVariable] + ccIsUnreachable :: a -> m Bool + ccSetNoReturn :: a -> m a + ccStartLoop :: a -> LoopSetup s -> m a + ccGetLoop :: a -> m (LoopSetup s) + ccPushCleanup :: a -> CleanupSetup a s -> m a + ccGetCleanup :: a -> m (CleanupSetup a s) + +type ExpressionType = Positional ValueType + +data MemberValue c = + MemberValue { + mvContext :: [c], + mvName :: VariableName, + mvType :: ValueType + } + deriving (Show) + +data ReturnVariable = + ReturnVariable { + rvIndex :: Int, + rvName :: VariableName, + rvType :: ValueType + } + deriving (Show) + +data LoopSetup s = + LoopSetup { + lsUpdate :: s + } | + NotInLoop + +data CleanupSetup a s = + CleanupSetup { + csReturnContext :: [a], + csCleanup :: s + } + +instance Show c => Show (VariableValue c) where + show (VariableValue c _ t _) = show t ++ formatFullContextBrace c + +reviseErrorStateT :: (CompileErrorM m) => CompilerState a m b -> String -> CompilerState a m b +reviseErrorStateT x s = mapStateT (`reviseError` s) x + +csCurrentScope :: CompilerContext c m s a => CompilerState a m SymbolScope +csCurrentScope = fmap ccCurrentScope get >>= lift + +csResolver :: CompilerContext c m s a => CompilerState a m AnyTypeResolver +csResolver = fmap ccResolver get >>= lift + +csSameType :: CompilerContext c m s a => TypeInstance -> CompilerState a m Bool +csSameType t = fmap (\x -> ccSameType x t) get >>= lift + +csAllFilters :: CompilerContext c m s a => CompilerState a m ParamFilters +csAllFilters = fmap ccAllFilters get >>= lift + +csGetParamScope :: CompilerContext c m s a => ParamName -> CompilerState a m SymbolScope +csGetParamScope n = fmap (\x -> ccGetParamScope x n) get >>= lift + +csRequiresTypes :: CompilerContext c m s a => Set.Set CategoryName -> CompilerState a m () +csRequiresTypes ns = fmap (\x -> ccRequiresTypes x ns) get >>= lift >>= put + +csGetRequired :: CompilerContext c m s a => CompilerState a m (Set.Set CategoryName) +csGetRequired = fmap ccGetRequired get >>= lift + +csGetCategoryFunction :: CompilerContext c m s a => + [c] -> Maybe CategoryName -> FunctionName -> CompilerState a m (ScopedFunction c) +csGetCategoryFunction c t n = fmap (\x -> ccGetCategoryFunction x c t n) get >>= lift + +csGetTypeFunction :: CompilerContext c m s a => + [c] -> Maybe GeneralInstance -> FunctionName -> CompilerState a m (ScopedFunction c) +csGetTypeFunction c t n = fmap (\x -> ccGetTypeFunction x c t n) get >>= lift + +csCheckValueInit :: CompilerContext c m s a => + [c] -> TypeInstance -> ExpressionType -> Positional GeneralInstance -> CompilerState a m () +csCheckValueInit c t as ps = fmap (\x -> ccCheckValueInit x c t as ps) get >>= lift + +csGetVariable :: CompilerContext c m s a => + [c] -> VariableName -> CompilerState a m (VariableValue c) +csGetVariable c n = fmap (\x -> ccGetVariable x c n) get >>= lift + +csAddVariable :: CompilerContext c m s a => + [c] -> VariableName -> VariableValue c -> CompilerState a m () +csAddVariable c n t = fmap (\x -> ccAddVariable x c n t) get >>= lift >>= put + +csCheckVariableInit :: CompilerContext c m s a => + [c] -> VariableName -> CompilerState a m () +csCheckVariableInit c n = fmap (\x -> ccCheckVariableInit x c n) get >>= lift + +csWrite :: CompilerContext c m s a => s -> CompilerState a m () +csWrite o = fmap (\x -> ccWrite x o) get >>= lift >>= put + +csClearOutput :: CompilerContext c m s a => CompilerState a m () +csClearOutput = fmap (\x -> ccClearOutput x) get >>= lift >>= put + +csGetOutput :: CompilerContext c m s a => CompilerState a m s +csGetOutput = fmap ccGetOutput get >>= lift + +csUpdateAssigned :: CompilerContext c m s a => VariableName -> CompilerState a m () +csUpdateAssigned n = fmap (\x -> ccUpdateAssigned x n) get >>= lift >>= put + +csInheritReturns :: CompilerContext c m s a => [a] -> CompilerState a m () +csInheritReturns xs = fmap (\x -> ccInheritReturns x xs) get >>= lift >>= put + +csRegisterReturn :: CompilerContext c m s a => + [c] -> Maybe ExpressionType -> CompilerState a m () +csRegisterReturn c rs = fmap (\x -> ccRegisterReturn x c rs) get >>= lift >>= put + +csPrimNamedReturns :: CompilerContext c m s a => CompilerState a m [ReturnVariable] +csPrimNamedReturns = fmap ccPrimNamedReturns get >>= lift + +csIsUnreachable :: CompilerContext c m s a => CompilerState a m Bool +csIsUnreachable = fmap ccIsUnreachable get >>= lift + +csSetNoReturn :: CompilerContext c m s a => CompilerState a m () +csSetNoReturn = fmap ccSetNoReturn get >>= lift >>= put + +csStartLoop :: CompilerContext c m s a => LoopSetup s -> CompilerState a m () +csStartLoop l = fmap (\x -> ccStartLoop x l) get >>= lift >>= put + +csGetLoop :: CompilerContext c m s a => CompilerState a m (LoopSetup s) +csGetLoop = fmap ccGetLoop get >>= lift + +csPushCleanup :: CompilerContext c m s a => CleanupSetup a s -> CompilerState a m () +csPushCleanup l = fmap (\x -> ccPushCleanup x l) get >>= lift >>= put + +csGetCleanup :: CompilerContext c m s a => CompilerState a m (CleanupSetup a s) +csGetCleanup = fmap ccGetCleanup get >>= lift + +data CompiledData s = + CompiledData { + cdRequired :: Set.Set CategoryName, + cdOutput :: s + } + +instance Monoid s => Mergeable (CompiledData s) where + mergeAny ds = CompiledData req out where + flat = foldr (:) [] ds + req = Set.unions $ map cdRequired flat + out = foldr (<>) mempty $ map cdOutput flat + mergeAll ds = CompiledData req out where + flat = foldr (:) [] ds + req = Set.unions $ map cdRequired flat + out = foldr (<>) mempty $ map cdOutput flat + +runDataCompiler :: CompilerContext c m s a => + CompilerState a m b -> a -> m (CompiledData s) +runDataCompiler x ctx = do + ctx' <- execStateT x ctx + required <- ccGetRequired ctx' + output <- ccGetOutput ctx' + return $ CompiledData { + cdRequired = required, + cdOutput = output + } + +getCleanContext :: CompilerContext c m s a => CompilerState a m a +getCleanContext = get >>= lift . ccClearOutput diff --git a/src/Compilation/ProcedureContext.hs b/src/Compilation/ProcedureContext.hs new file mode 100644 --- /dev/null +++ b/src/Compilation/ProcedureContext.hs @@ -0,0 +1,510 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} + +module Compilation.ProcedureContext ( + ProcedureContext(..), + ReturnValidation(..), + updateArgVariables, + updateReturnVariables, +) where + +import Control.Monad (when) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Base.CompileError +import Base.Mergeable +import Compilation.CompilerState +import Types.DefinedCategory +import Types.Function +import Types.GeneralType +import Types.Positional +import Types.Procedure +import Types.TypeCategory +import Types.TypeInstance + + +data ProcedureContext c = + ProcedureContext { + pcScope :: SymbolScope, + pcType :: CategoryName, + pcExtParams :: Positional (ValueParam c), + pcIntParams :: Positional (ValueParam c), + pcMembers :: [DefinedMember c], + pcCategories :: CategoryMap c, + pcAllFilters :: ParamFilters, + pcExtFilters :: [ParamFilter c], + pcIntFilters :: [ParamFilter c], + pcParamScopes :: Map.Map ParamName SymbolScope, + pcFunctions :: Map.Map FunctionName (ScopedFunction c), + pcVariables :: Map.Map VariableName (VariableValue c), + pcReturns :: ReturnValidation c, + pcPrimNamed :: [ReturnVariable], + pcRequiredTypes :: Set.Set CategoryName, + pcOutput :: [String], + pcDisallowInit :: Bool, + pcLoopSetup :: LoopSetup [String], + pcCleanupSetup :: CleanupSetup (ProcedureContext c) [String] + } + +data ReturnValidation c = + ValidatePositions { + vpReturns :: Positional (PassedValue c) + } | + ValidateNames { + vnTypes :: Positional (PassedValue c), + vnRemaining :: Map.Map VariableName (PassedValue c) + } | + UnreachableCode + +instance (Show c, MergeableM m, CompileErrorM m) => + CompilerContext c m [String] (ProcedureContext c) where + ccCurrentScope = return . pcScope + ccResolver = return . AnyTypeResolver . CategoryResolver . pcCategories + ccSameType ctx = return . (== same) where + same = TypeInstance (pcType ctx) (fmap (SingleType . JustParamName . vpParam) $ pcExtParams ctx) + ccAllFilters = return . pcAllFilters + ccGetParamScope ctx p = do + case p `Map.lookup` pcParamScopes ctx of + (Just s) -> return s + _ -> compileError $ "Param " ++ show p ++ " does not exist" + ccRequiresTypes ctx ts = return $ + ProcedureContext { + pcScope = pcScope ctx, + pcType = pcType ctx, + pcExtParams = pcExtParams ctx, + pcIntParams = pcIntParams ctx, + pcMembers = pcMembers ctx, + pcCategories = pcCategories ctx, + pcAllFilters = pcAllFilters ctx, + pcExtFilters = pcExtFilters ctx, + pcIntFilters = pcIntFilters ctx, + pcParamScopes = pcParamScopes ctx, + pcFunctions = pcFunctions ctx, + pcVariables = pcVariables ctx, + pcReturns = pcReturns ctx, + pcPrimNamed = pcPrimNamed ctx, + pcRequiredTypes = Set.union (pcRequiredTypes ctx) ts, + pcOutput = pcOutput ctx, + pcDisallowInit = pcDisallowInit ctx, + pcLoopSetup = pcLoopSetup ctx, + pcCleanupSetup = pcCleanupSetup ctx + } + ccGetRequired = return . pcRequiredTypes + ccGetCategoryFunction ctx c Nothing n = ccGetCategoryFunction ctx c (Just $ pcType ctx) n + ccGetCategoryFunction ctx c (Just t) n = getFunction where + getFunction + -- Same category as the procedure itself. + | t == pcType ctx = checkFunction $ n `Map.lookup` pcFunctions ctx + -- A different category than the procedure. + | otherwise = do + (_,ca) <- getCategory (pcCategories ctx) (c,t) + let params = Positional $ map vpParam $ getCategoryParams ca + let fa = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions ca + checkFunction $ n `Map.lookup` fa + checkFunction (Just f) = do + when (pcDisallowInit ctx && t == pcType ctx && pcScope ctx == CategoryScope) $ + compileError $ "Function " ++ show n ++ + " disallowed during initialization" ++ formatFullContextBrace c + when (sfScope f /= CategoryScope) $ + compileError $ "Function " ++ show n ++ " in " ++ show t ++ " cannot be used as a category function" + return f + checkFunction _ = + compileError $ "Category " ++ show t ++ + " does not have a category function named " ++ show n ++ + formatFullContextBrace c + ccGetTypeFunction ctx c t n = getFunction t where + getFunction (Just t@(TypeMerge MergeUnion _)) = + compileError $ "Use explicit type conversion to call " ++ show n ++ " for union type " ++ + show t ++ formatFullContextBrace c + getFunction (Just t@(TypeMerge MergeIntersect ts)) = + collectOneOrErrorM $ map getFunction $ map Just ts + getFunction (Just (SingleType (JustParamName p))) = do + fa <- ccAllFilters ctx + fs <- case p `Map.lookup` fa of + (Just fs) -> return fs + _ -> compileError $ "Param " ++ show p ++ " does not exist" + let ts = map tfType $ filter isRequiresFilter fs + let ds = map dfType $ filter isDefinesFilter fs + collectOneOrErrorM $ + [compileError $ "Function " ++ show n ++ " not available for param " ++ show p ++ + formatFullContextBrace c] ++ + (map getFunction $ map (Just . SingleType) ts) ++ (map checkDefine ds) + getFunction (Just (SingleType (JustTypeInstance t))) + -- Same category as the procedure itself. + | tiName t == pcType ctx = + checkFunction (tiName t) (fmap vpParam $ pcExtParams ctx) (tiParams t) $ n `Map.lookup` pcFunctions ctx + -- A different category than the procedure. + | otherwise = do + (_,ca) <- getCategory (pcCategories ctx) (c,tiName t) + let params = Positional $ map vpParam $ getCategoryParams ca + let fa = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions ca + checkFunction (tiName t) params (tiParams t) $ n `Map.lookup` fa + getFunction Nothing = do + let ps = fmap (SingleType . JustParamName . vpParam) $ pcExtParams ctx + getFunction (Just $ SingleType $ JustTypeInstance $ TypeInstance (pcType ctx) ps) + checkDefine t = do + (_,ca) <- getCategory (pcCategories ctx) (c,diName t) + let params = Positional $ map vpParam $ getCategoryParams ca + let fa = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions ca + checkFunction (diName t) params (diParams t) $ n `Map.lookup` fa + checkFunction t2 ps1 ps2 (Just f) = do + when (pcDisallowInit ctx && t2 == pcType ctx) $ + compileError $ "Function " ++ show n ++ + " disallowed during initialization" ++ formatFullContextBrace c + when (sfScope f == CategoryScope) $ + compileError $ "Function " ++ show n ++ " in " ++ show t2 ++ + " is a category function" ++ formatFullContextBrace c + paired <- processPairs alwaysPair ps1 ps2 `reviseError` + ("In external function call at " ++ formatFullContext c) + let assigned = Map.fromList paired + uncheckedSubFunction assigned f + checkFunction t2 _ _ _ = + compileError $ "Category " ++ show t2 ++ + " does not have a type or value function named " ++ show n ++ + formatFullContextBrace c + ccCheckValueInit ctx c (TypeInstance t as) ts ps + | t /= pcType ctx = + compileError $ "Category " ++ show (pcType ctx) ++ " cannot initialize values from " ++ + show t ++ formatFullContextBrace c + | otherwise = flip reviseError ("In initialization at " ++ formatFullContext c) $ do + let t' = TypeInstance (pcType ctx) as + r <- ccResolver ctx + allFilters <- ccAllFilters ctx + pa <- fmap Map.fromList $ processPairs alwaysPair (fmap vpParam $ pcExtParams ctx) as + pa2 <- fmap Map.fromList $ processPairs alwaysPair (fmap vpParam $ pcIntParams ctx) ps + let pa' = Map.union pa pa2 + validateTypeInstance r allFilters t' + -- Check internal param substitution. + let mapped = Map.fromListWith (++) $ map (\f -> (pfParam f,[pfFilter f])) (pcIntFilters ctx) + let positional = map (getFilters mapped) (map vpParam $ pValues $ pcIntParams ctx) + assigned <- fmap Map.fromList $ processPairs alwaysPair (fmap vpParam $ pcIntParams ctx) ps + subbed <- fmap Positional $ collectAllOrErrorM $ map (assignFilters assigned) positional + processPairs (validateAssignment r allFilters) ps subbed + -- Check initializer types. + ms <- fmap Positional $ collectAllOrErrorM $ map (subSingle pa') (pcMembers ctx) + processPairs (checkInit r allFilters) ms (Positional $ zip [1..] $ pValues ts) + return () + where + getFilters fm n = + case n `Map.lookup` fm of + (Just fs) -> fs + _ -> [] + assignFilters fm fs = do + collectAllOrErrorM $ map (uncheckedSubFilter $ getValueForParam fm) fs + checkInit r fa (MemberValue c n t0) (i,t1) = do + checkValueTypeMatch r fa t1 t0 `reviseError` + ("In initializer " ++ show i ++ " for " ++ show n ++ formatFullContextBrace c) + subSingle pa (DefinedMember c _ t n _) = do + t' <- uncheckedSubValueType (getValueForParam pa) t + return $ MemberValue c n t' + ccGetVariable ctx c n = + case n `Map.lookup` pcVariables ctx of + (Just v) -> return v + _ -> compileError $ "Variable " ++ show n ++ " is not defined" ++ + formatFullContextBrace c + ccAddVariable ctx c n t = do + case n `Map.lookup` pcVariables ctx of + Nothing -> return () + (Just v) -> compileError $ "Variable " ++ show n ++ + formatFullContextBrace c ++ + " is already defined: " ++ show v + return $ ProcedureContext { + pcScope = pcScope ctx, + pcType = pcType ctx, + pcExtParams = pcExtParams ctx, + pcIntParams = pcIntParams ctx, + pcMembers = pcMembers ctx, + pcCategories = pcCategories ctx, + pcAllFilters = pcAllFilters ctx, + pcExtFilters = pcExtFilters ctx, + pcIntFilters = pcIntFilters ctx, + pcParamScopes = pcParamScopes ctx, + pcFunctions = pcFunctions ctx, + pcVariables = Map.insert n t (pcVariables ctx), + pcReturns = pcReturns ctx, + pcPrimNamed = pcPrimNamed ctx, + pcRequiredTypes = pcRequiredTypes ctx, + pcOutput = pcOutput ctx, + pcDisallowInit = pcDisallowInit ctx, + pcLoopSetup = pcLoopSetup ctx, + pcCleanupSetup = pcCleanupSetup ctx + } + ccCheckVariableInit ctx c n = + case pcReturns ctx of + ValidateNames _ na -> when (n `Map.member` na) $ + compileError $ "Named return " ++ show n ++ " might not be initialized" ++ formatFullContextBrace c + _ -> return () + ccWrite ctx ss = return $ + ProcedureContext { + pcScope = pcScope ctx, + pcType = pcType ctx, + pcExtParams = pcExtParams ctx, + pcIntParams = pcIntParams ctx, + pcMembers = pcMembers ctx, + pcCategories = pcCategories ctx, + pcAllFilters = pcAllFilters ctx, + pcExtFilters = pcExtFilters ctx, + pcIntFilters = pcIntFilters ctx, + pcParamScopes = pcParamScopes ctx, + pcFunctions = pcFunctions ctx, + pcVariables = pcVariables ctx, + pcReturns = pcReturns ctx, + pcPrimNamed = pcPrimNamed ctx, + pcRequiredTypes = pcRequiredTypes ctx, + pcOutput = pcOutput ctx ++ ss, + pcDisallowInit = pcDisallowInit ctx, + pcLoopSetup = pcLoopSetup ctx, + pcCleanupSetup = pcCleanupSetup ctx + } + ccGetOutput = return . pcOutput + ccClearOutput ctx = return $ ProcedureContext { + pcScope = pcScope ctx, + pcType = pcType ctx, + pcExtParams = pcExtParams ctx, + pcIntParams = pcIntParams ctx, + pcMembers = pcMembers ctx, + pcCategories = pcCategories ctx, + pcAllFilters = pcAllFilters ctx, + pcExtFilters = pcExtFilters ctx, + pcIntFilters = pcIntFilters ctx, + pcParamScopes = pcParamScopes ctx, + pcFunctions = pcFunctions ctx, + pcVariables = pcVariables ctx, + pcReturns = pcReturns ctx, + pcPrimNamed = pcPrimNamed ctx, + pcRequiredTypes = pcRequiredTypes ctx, + pcOutput = [], + pcDisallowInit = pcDisallowInit ctx, + pcLoopSetup = pcLoopSetup ctx, + pcCleanupSetup = pcCleanupSetup ctx + } + ccUpdateAssigned ctx n = update (pcReturns ctx) where + update (ValidateNames ts ra) = return $ ProcedureContext { + pcScope = pcScope ctx, + pcType = pcType ctx, + pcExtParams = pcExtParams ctx, + pcIntParams = pcIntParams ctx, + pcMembers = pcMembers ctx, + pcCategories = pcCategories ctx, + pcAllFilters = pcAllFilters ctx, + pcExtFilters = pcExtFilters ctx, + pcIntFilters = pcIntFilters ctx, + pcParamScopes = pcParamScopes ctx, + pcFunctions = pcFunctions ctx, + pcVariables = pcVariables ctx, + pcReturns = ValidateNames ts $ Map.delete n ra, + pcPrimNamed = pcPrimNamed ctx, + pcRequiredTypes = pcRequiredTypes ctx, + pcOutput = pcOutput ctx, + pcDisallowInit = pcDisallowInit ctx, + pcLoopSetup = pcLoopSetup ctx, + pcCleanupSetup = pcCleanupSetup ctx + } + update _ = return ctx + ccInheritReturns ctx cs = return $ ProcedureContext { + pcScope = pcScope ctx, + pcType = pcType ctx, + pcExtParams = pcExtParams ctx, + pcIntParams = pcIntParams ctx, + pcMembers = pcMembers ctx, + pcCategories = pcCategories ctx, + pcAllFilters = pcAllFilters ctx, + pcExtFilters = pcExtFilters ctx, + pcIntFilters = pcIntFilters ctx, + pcParamScopes = pcParamScopes ctx, + pcFunctions = pcFunctions ctx, + pcVariables = pcVariables ctx, + pcReturns = combineSeries (pcReturns ctx) inherited, + pcPrimNamed = pcPrimNamed ctx, + pcRequiredTypes = pcRequiredTypes ctx, + pcOutput = pcOutput ctx, + pcDisallowInit = pcDisallowInit ctx, + pcLoopSetup = pcLoopSetup ctx, + pcCleanupSetup = pcCleanupSetup ctx + } + where + inherited = foldr combineParallel UnreachableCode (map pcReturns cs) + combineSeries _ UnreachableCode = UnreachableCode + combineSeries UnreachableCode _ = UnreachableCode + combineSeries r@(ValidatePositions _) _ = r + combineSeries _ r@(ValidatePositions _) = r + combineSeries (ValidateNames ts ra1) (ValidateNames _ ra2) = ValidateNames ts $ Map.intersection ra1 ra2 + combineParallel UnreachableCode r = r + combineParallel r UnreachableCode = r + combineParallel (ValidateNames ts ra1) (ValidateNames _ ra2) = ValidateNames ts $ Map.union ra1 ra2 + combineParallel r@(ValidatePositions _) _ = r + ccRegisterReturn ctx c vs = do + check (pcReturns ctx) + return $ ProcedureContext { + pcScope = pcScope ctx, + pcType = pcType ctx, + pcExtParams = pcExtParams ctx, + pcIntParams = pcIntParams ctx, + pcMembers = pcMembers ctx, + pcCategories = pcCategories ctx, + pcAllFilters = pcAllFilters ctx, + pcExtFilters = pcExtFilters ctx, + pcIntFilters = pcIntFilters ctx, + pcParamScopes = pcParamScopes ctx, + pcFunctions = pcFunctions ctx, + pcVariables = pcVariables ctx, + pcReturns = UnreachableCode, + pcPrimNamed = pcPrimNamed ctx, + pcRequiredTypes = pcRequiredTypes ctx, + pcOutput = pcOutput ctx, + pcDisallowInit = pcDisallowInit ctx, + pcLoopSetup = pcLoopSetup ctx, + pcCleanupSetup = pcCleanupSetup ctx + } + where + check (ValidatePositions rs) = do + let vs' = case vs of + Nothing -> Positional [] + Just vs -> vs + processPairs checkReturnType rs (Positional $ zip [1..] $ pValues vs') `reviseError` + ("In procedure return at " ++ formatFullContext c) + return () + where + checkReturnType ta0@(PassedValue c0 t0) (n,t) = do + r <- ccResolver ctx + pa <- ccAllFilters ctx + checkValueTypeMatch r pa t t0 `reviseError` + ("Cannot convert " ++ show t ++ " to " ++ show ta0 ++ " in return " ++ + show n ++ " at " ++ formatFullContext c) + check (ValidateNames ts ra) = + case vs of + Just vs -> check (ValidatePositions ts) + Nothing -> mergeAllM $ map alwaysError $ Map.toList ra where + alwaysError (n,t) = compileError $ "Named return " ++ show n ++ " (" ++ show t ++ + ") might not have been set before return at " ++ + formatFullContext c + check _ = return () + ccPrimNamedReturns = return . pcPrimNamed + ccIsUnreachable ctx = return $ match (pcReturns ctx) where + match UnreachableCode = True + match _ = False + ccSetNoReturn ctx = + return $ ProcedureContext { + pcScope = pcScope ctx, + pcType = pcType ctx, + pcExtParams = pcExtParams ctx, + pcIntParams = pcIntParams ctx, + pcMembers = pcMembers ctx, + pcCategories = pcCategories ctx, + pcAllFilters = pcAllFilters ctx, + pcExtFilters = pcExtFilters ctx, + pcIntFilters = pcIntFilters ctx, + pcParamScopes = pcParamScopes ctx, + pcFunctions = pcFunctions ctx, + pcVariables = pcVariables ctx, + pcReturns = UnreachableCode, + pcPrimNamed = pcPrimNamed ctx, + pcRequiredTypes = pcRequiredTypes ctx, + pcOutput = pcOutput ctx, + pcDisallowInit = pcDisallowInit ctx, + pcLoopSetup = pcLoopSetup ctx, + pcCleanupSetup = pcCleanupSetup ctx + } + ccStartLoop ctx l = + return $ ProcedureContext { + pcScope = pcScope ctx, + pcType = pcType ctx, + pcExtParams = pcExtParams ctx, + pcIntParams = pcIntParams ctx, + pcMembers = pcMembers ctx, + pcCategories = pcCategories ctx, + pcAllFilters = pcAllFilters ctx, + pcExtFilters = pcExtFilters ctx, + pcIntFilters = pcIntFilters ctx, + pcParamScopes = pcParamScopes ctx, + pcFunctions = pcFunctions ctx, + pcVariables = pcVariables ctx, + pcReturns = pcReturns ctx, + pcPrimNamed = pcPrimNamed ctx, + pcRequiredTypes = pcRequiredTypes ctx, + pcOutput = pcOutput ctx, + pcDisallowInit = pcDisallowInit ctx, + pcLoopSetup = l, + pcCleanupSetup = pcCleanupSetup ctx + } + ccGetLoop = return . pcLoopSetup + ccPushCleanup ctx (CleanupSetup cs ss) = + return $ ProcedureContext { + pcScope = pcScope ctx, + pcType = pcType ctx, + pcExtParams = pcExtParams ctx, + pcIntParams = pcIntParams ctx, + pcMembers = pcMembers ctx, + pcCategories = pcCategories ctx, + pcAllFilters = pcAllFilters ctx, + pcExtFilters = pcExtFilters ctx, + pcIntFilters = pcIntFilters ctx, + pcParamScopes = pcParamScopes ctx, + pcFunctions = pcFunctions ctx, + pcVariables = pcVariables ctx, + pcReturns = pcReturns ctx, + pcPrimNamed = pcPrimNamed ctx, + pcRequiredTypes = pcRequiredTypes ctx, + pcOutput = pcOutput ctx, + pcDisallowInit = pcDisallowInit ctx, + pcLoopSetup = pcLoopSetup ctx, + pcCleanupSetup = CleanupSetup (cs ++ (csReturnContext $ pcCleanupSetup ctx)) + (ss ++ (csCleanup $ pcCleanupSetup ctx)) + } + ccGetCleanup = return . pcCleanupSetup + +updateReturnVariables :: (Show c, CompileErrorM m, MergeableM m) => + (Map.Map VariableName (VariableValue c)) -> + Positional (PassedValue c) -> ReturnValues c -> + m (Map.Map VariableName (VariableValue c)) +updateReturnVariables ma rs1 rs2 = updated where + updated + | isUnnamedReturns rs2 = return ma + | otherwise = do + rs <- processPairs alwaysPair rs1 (nrNames rs2) + foldr update (return ma) rs where + update (PassedValue c t,r) va = do + va' <- va + case ovName r `Map.lookup` va' of + Nothing -> return $ Map.insert (ovName r) (VariableValue c LocalScope t True) va' + (Just v) -> compileError $ "Variable " ++ show (ovName r) ++ + formatFullContextBrace (ovContext r) ++ + " is already defined" ++ + formatFullContextBrace (vvContext v) + +updateArgVariables :: (Show c, CompileErrorM m, MergeableM m) => + (Map.Map VariableName (VariableValue c)) -> + Positional (PassedValue c) -> ArgValues c -> + m (Map.Map VariableName (VariableValue c)) +updateArgVariables ma as1 as2 = do + as <- processPairs alwaysPair as1 (avNames as2) + let as' = filter (not . isDiscardedInput . snd) as + foldr update (return ma) as' where + update (PassedValue c t,a) va = do + va' <- va + case ivName a `Map.lookup` va' of + Nothing -> return $ Map.insert (ivName a) (VariableValue c LocalScope t False) va' + (Just v) -> compileError $ "Variable " ++ show (ivName a) ++ + formatFullContextBrace (ivContext a) ++ + " is already defined" ++ + formatFullContextBrace (vvContext v) diff --git a/src/Compilation/ScopeContext.hs b/src/Compilation/ScopeContext.hs new file mode 100644 --- /dev/null +++ b/src/Compilation/ScopeContext.hs @@ -0,0 +1,121 @@ +{- ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Compilation.ScopeContext ( + ProcedureScope(..), + ScopeContext(..), + applyProcedureScope, + builtinVariables, + getProcedureScopes, +) where + +import Control.Monad (when) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Base.CompileError +import Base.Mergeable +import Types.DefinedCategory +import Types.Function +import Types.GeneralType +import Types.Positional +import Types.Procedure +import Types.TypeCategory +import Types.TypeInstance + + +data ScopeContext c = + ScopeContext { + scCategories :: CategoryMap c, + scName :: CategoryName, + scExternalParams :: Positional (ValueParam c), + scInternalparams :: Positional (ValueParam c), + scMembers :: [DefinedMember c], + scExternalFilters :: [ParamFilter c], + scInternalFilters :: [ParamFilter c], + scFunctions :: Map.Map FunctionName (ScopedFunction c), + scVariables :: Map.Map VariableName (VariableValue c) + } + +data ProcedureScope c = + ProcedureScope { + psContext :: ScopeContext c, + psProcedures :: [(ScopedFunction c,ExecutableProcedure c)] + } + +applyProcedureScope :: + (ScopeContext c -> ScopedFunction c -> ExecutableProcedure c -> a) -> ProcedureScope c -> [a] +applyProcedureScope f (ProcedureScope ctx fs) = map (uncurry (f ctx)) fs + +getProcedureScopes :: (Show c, CompileErrorM m, MergeableM m) => + CategoryMap c -> [Namespace] -> DefinedCategory c -> m [ProcedureScope c] +getProcedureScopes ta ns dd@(DefinedCategory c n pi _ _ fi ms ps fs) = do + (_,t) <- getConcreteCategory ta (c,n) + let params = Positional $ getCategoryParams t + let params2 = Positional pi + let typeInstance = TypeInstance n $ fmap (SingleType . JustParamName . vpParam) params + let filters = getCategoryFilters t + let filters2 = fi + let r = CategoryResolver ta + fa <- setInternalFunctions r t fs + checkInternalParams pi fi (getCategoryParams t) (Map.elems fa) r (getCategoryFilterMap t) + pa <- pairProceduresToFunctions fa ps + let (cp,tp,vp) = partitionByScope (sfScope . fst) pa + let (cm,tm,vm) = partitionByScope dmScope ms + let cm0 = builtins typeInstance CategoryScope + let tm0 = builtins typeInstance TypeScope + let vm0 = builtins typeInstance ValueScope + cm' <- mapMembers cm + tm' <- mapMembers $ cm ++ tm + vm' <- mapMembers $ cm ++ tm ++ vm + let cv = Map.union cm0 cm' + let tv = Map.union tm0 tm' + let vv = Map.union vm0 vm' + let ctxC = ScopeContext ta n params params2 vm filters filters2 fa cv + let ctxT = ScopeContext ta n params params2 vm filters filters2 fa tv + let ctxV = ScopeContext ta n params params2 vm filters filters2 fa vv + return [ProcedureScope ctxC cp,ProcedureScope ctxT tp,ProcedureScope ctxV vp] + where + builtins t s0 = Map.filter ((<= s0) . vvScope) $ builtinVariables t + checkInternalParams pi fi pe fs r fa = do + let pm = Map.fromList $ map (\p -> (vpParam p,vpContext p)) pi + mergeAllM $ map (checkFunction pm) fs + mergeAllM $ map (checkParam pm) pe + let fa' = Map.union fa $ getFilterMap pi fi + mergeAllM $ map (checkFilter r fa') fi + checkFilter r fa (ParamFilter c n f) = + validateTypeFilter r fa f `reviseError` + (show n ++ " " ++ show f ++ formatFullContextBrace c) + checkFunction pm f = + when (sfScope f == ValueScope) $ + mergeAllM $ map (checkParam pm) $ pValues $ sfParams f + checkParam pm p = + case vpParam p `Map.lookup` pm of + Nothing -> return () + (Just c) -> compileError $ "Internal param " ++ show (vpParam p) ++ + formatFullContextBrace c ++ + " is already defined at " ++ + formatFullContext (vpContext p) + +-- TODO: This is probably in the wrong module. +builtinVariables :: TypeInstance -> Map.Map VariableName (VariableValue c) +builtinVariables t = Map.fromList [ + (VariableName "self",VariableValue [] ValueScope (ValueType RequiredValue $ SingleType $ JustTypeInstance t) False) + ] diff --git a/src/CompilerCxx/Category.hs b/src/CompilerCxx/Category.hs new file mode 100644 --- /dev/null +++ b/src/CompilerCxx/Category.hs @@ -0,0 +1,689 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} + +module CompilerCxx.Category ( + CategoryModule(..), + CxxOutput(..), + PrivateSource(..), + createMainFile, + createTestFile, + compileCategoryDeclaration, + compileCategoryModule, + compileConcreteDefinition, + compileConcreteTemplate, + compileInterfaceDefinition, + compileModuleMain, +) where + +import Data.List (intercalate,nub,sortOn) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Base.CompileError +import Base.Mergeable +import Compilation.CompilerState +import Compilation.ScopeContext +import CompilerCxx.CategoryContext +import CompilerCxx.Code +import CompilerCxx.Naming +import CompilerCxx.Procedure +import Types.Builtin +import Types.DefinedCategory +import Types.Function +import Types.GeneralType +import Types.Positional +import Types.Procedure +import Types.TypeCategory +import Types.TypeInstance +import Types.Variance + + +data CxxOutput = + CxxOutput { + coCategory :: Maybe CategoryName, + coFilename :: String, + coNamespace :: Namespace, + coUsesNamespace :: [Namespace], + coUsesCategory :: [CategoryName], + coOutput :: [String] + } + +data CategoryModule c = + CategoryModule { + cnBase :: CategoryMap c, + cnNamespaces :: [Namespace], + cnPublic :: [AnyCategory c], + cnPrivate :: [PrivateSource c] + } + +data PrivateSource c = + PrivateSource { + psNamespace :: Namespace, + psCategory :: [AnyCategory c], + psDefine :: [DefinedCategory c] + } + +compileCategoryModule :: (Show c, CompileErrorM m, MergeableM m) => + CategoryModule c -> m [CxxOutput] +compileCategoryModule (CategoryModule tm ns cs xa) = do + tm' <- includeNewTypes tm cs + hxx <- collectAllOrErrorM $ map (compileCategoryDeclaration tm') cs + let interfaces = filter (not . isValueConcrete) cs + cxx <- collectAllOrErrorM $ map compileInterfaceDefinition interfaces + xa <- collectAllOrErrorM $ map compileInternal xa + let xx = concat $ map snd xa + let dm = Map.fromListWith (++) $ map (\d -> (dcName d,[d])) $ concat $ map fst xa + checkDuplicates dm cs + return $ hxx ++ cxx ++ xx where + compileInternal (PrivateSource ns1 cs2 ds) = do + let cs' = cs++cs2 + tm' <- includeNewTypes tm cs' + hxx <- collectAllOrErrorM $ map (compileCategoryDeclaration tm') cs2 + let interfaces = filter (not . isValueConcrete) cs2 + cxx1 <- collectAllOrErrorM $ map compileInterfaceDefinition interfaces + cxx2 <- collectAllOrErrorM $ map (compileDefinition tm' (ns1:ns)) ds + return (ds,hxx ++ cxx1 ++ cxx2) + compileDefinition tm ns d = do + tm' <- mergeInternalInheritance tm d + compileConcreteDefinition tm' ns d + checkDuplicates dm = mergeAllM . map (check dm) + check dm t = + case getCategoryName t `Map.lookup` dm of + Nothing -> return () + Just [_] -> return () + Just ds -> + flip reviseError ("Public category " ++ show (getCategoryName t) ++ + formatFullContextBrace (getCategoryContext t) ++ + " is defined " ++ show (length ds) ++ " times") $ + mergeAllM $ map (\d -> compileError $ "Defined at " ++ formatFullContext (dcContext d)) ds + +compileModuleMain :: (Show c, CompileErrorM m, MergeableM m) => + CategoryModule c -> CategoryName -> FunctionName -> m CxxOutput +compileModuleMain (CategoryModule tm ns cs xa) n f = do + tm' <- includeNewTypes tm cs + xx <- fmap concat $ collectAllOrErrorM $ filter (not . isCompileError) $ map maybeCompileMain xa + reconcile xx where + maybeCompileMain (PrivateSource _ cs2 ds) = do + let cs' = cs++cs2 + tm' <- includeNewTypes tm cs' + let dm = Set.fromList $ map dcName ds + if n `Set.member` dm + then do + (ns,main) <- createMainFile tm' n f + return [CxxOutput Nothing mainFilename NoNamespace [ns] [n] main] + else return [] + reconcile [x] = return x + reconcile [] = compileErrorM $ "No matches for main category " ++ show n + reconcile _ = compileErrorM $ "Multiple matches for main category " ++ show n + +compileCategoryDeclaration :: (Show c, CompileErrorM m, MergeableM m) => + CategoryMap c -> AnyCategory c -> m CxxOutput +compileCategoryDeclaration _ t = + return $ CxxOutput (Just $ getCategoryName t) + (headerFilename name) + (getCategoryNamespace t) + [getCategoryNamespace t] + (filter (not . isBuiltinCategory) $ Set.toList $ cdRequired file) + (cdOutput file) where + file = mergeAll $ [ + CompiledData depends [], + onlyCodes guardTop, + onlyCodes baseHeaderIncludes, + addNamespace t content, + onlyCodes guardBottom + ] + depends = getCategoryDeps t + content = onlyCodes $ collection ++ labels ++ getCategory ++ getType + name = getCategoryName t + guardTop = ["#ifndef " ++ guardName,"#define " ++ guardName] + guardBottom = ["#endif // " ++ guardName] + guardName = "HEADER_" ++ guardNamespace ++ show name + guardNamespace + | isStaticNamespace $ getCategoryNamespace t = show (getCategoryNamespace t) ++ "_" + | otherwise = "" + labels = map label $ filter ((== name) . sfType) $ getCategoryFunctions t + label f = "extern " ++ functionLabelType f ++ " " ++ functionName f ++ ";" + collection + | isValueConcrete t = [] + | otherwise = ["extern const void* const " ++ collectionName name ++ ";"] + getCategory + | isInstanceInterface t = [] + | otherwise = declareGetCategory t + getType + | isInstanceInterface t = [] + | otherwise = declareGetType t + +compileInterfaceDefinition :: MergeableM m => AnyCategory c -> m CxxOutput +compileInterfaceDefinition t = do + top <- return emptyCode + bottom <- return emptyCode + ce <- return emptyCode + te <- typeConstructor + commonDefineAll t [] emptyCode emptyCode emptyCode te [] + where + typeConstructor = do + let ps = map vpParam $ getCategoryParams t + let argParent = categoryName (getCategoryName t) ++ "& p" + let argsPassed = "Params<" ++ show (length ps) ++ ">::Type params" + let allArgs = intercalate ", " [argParent,argsPassed] + let initParent = "parent(p)" + let initPassed = map (\(i,p) -> paramName p ++ "(*std::get<" ++ show i ++ ">(params))") $ zip [0..] ps + let allInit = intercalate ", " $ initParent:initPassed + return $ onlyCode $ typeName (getCategoryName t) ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" + +compileConcreteTemplate :: (Show c, CompileErrorM m, MergeableM m) => + CategoryMap c -> CategoryName -> m CxxOutput +compileConcreteTemplate ta n = do + (_,t) <- getConcreteCategory ta ([],n) + compileConcreteDefinition ta [] (defined t) `reviseError` ("In generated template for " ++ show n) where + defined t = DefinedCategory { + dcContext = [], + dcName = getCategoryName t, + dcParams = [], + dcRefines = [], + dcDefines = [], + dcParamFilter = [], + dcMembers = [], + dcProcedures = map defaultFail (getCategoryFunctions t), + dcFunctions = [] + } + defaultFail f = ExecutableProcedure { + epContext = [], + epEnd = [], + epName = sfName f, + epArgs = ArgValues [] $ Positional $ map createArg [1..(length $ pValues $ sfArgs f)], + epReturns = UnnamedReturns [], + epProcedure = failProcedure f + } + createArg = InputValue [] . VariableName . ("arg" ++) . show + failProcedure f = Procedure [] [ + NoValueExpression [] $ LineComment $ "// TODO: Implement " ++ funcName f ++ ".", + FailCall [] (Literal (StringLiteral [] $ funcName f ++ " is not implemented")) + ] + funcName f = show (sfType f) ++ "." ++ show (sfName f) + +compileConcreteDefinition :: (Show c, CompileErrorM m, MergeableM m) => + CategoryMap c -> [Namespace] -> DefinedCategory c -> m CxxOutput +compileConcreteDefinition ta ns dd@(DefinedCategory c n pi _ _ fi ms ps fs) = do + (_,t) <- getConcreteCategory ta (c,n) + let r = CategoryResolver ta + [cp,tp,vp] <- getProcedureScopes ta ns dd + cf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure cp + tf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure tp + vf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure vp + -- Functions explicitly declared externally. + let externalFuncs = Set.fromList $ map sfName $ filter ((== n) . sfType) $ getCategoryFunctions t + -- Functions explicitly declared internally. + let overrideFuncs = Map.fromList $ map (\f -> (sfName f,f)) fs + -- Functions only declared internally. + let internalFuncs = Map.filter (not . (`Set.member` externalFuncs) . sfName) overrideFuncs + let (cm,tm,vm) = partitionByScope dmScope ms + disallowTypeMembers tm + let internalCount = length pi + let memberCount = length vm + let fe = Map.elems internalFuncs + let allFuncs = getCategoryFunctions t ++ fe + let filters = getCategoryFilters t + let filters2 = fi + let allFilters = getFilterMap (getCategoryParams t ++ pi) $ filters ++ filters2 + top <- mergeAllM [ + return $ onlyCode $ "class " ++ valueName n ++ ";", + declareInternalValue n internalCount memberCount + ] + defineValue <- mergeAllM [ + return $ onlyCode $ "struct " ++ valueName n ++ " : public " ++ valueBase ++ " {", + fmap indentCompiled $ valueConstructor ta t vm, + fmap indentCompiled $ valueDispatch allFuncs, + return $ indentCompiled $ defineCategoryName2 n, + return $ indentCompiled $ mergeAll $ map fst vf, + fmap indentCompiled $ mergeAllM $ map (createMember r allFilters) vm, + fmap indentCompiled $ createParams, + return $ indentCompiled $ onlyCode $ typeName n ++ "& parent;", + return $ onlyCode "};" + ] + bottom <- mergeAllM $ [ + return $ defineValue, + defineInternalValue n internalCount memberCount + ] ++ map (return . snd) (cf ++ tf ++ vf) + ce <- mergeAllM [ + categoryConstructor ta t cm, + categoryDispatch allFuncs, + return $ mergeAll $ map fst cf, + mergeAllM $ map (createMemberLazy r allFilters) cm + ] + te <- mergeAllM [ + typeConstructor ta t tm, + typeDispatch allFuncs, + return $ mergeAll $ map fst tf, + mergeAllM $ map (createMember r allFilters) tm + ] + commonDefineAll t ns top bottom ce te fe + where + disallowTypeMembers :: (Show c, CompileErrorM m, MergeableM m) => + [DefinedMember c] -> m () + disallowTypeMembers tm = + mergeAllM $ flip map tm + (\m -> compileError $ "Member " ++ show (dmName m) ++ + " is not allowed to be @type-scoped" ++ + formatFullContextBrace (dmContext m)) + createParams = mergeAllM $ map createParam pi + createParam p = return $ onlyCode $ paramType ++ " " ++ paramName (vpParam p) ++ ";" + -- TODO: Can probably remove this if @type members are disallowed. Or, just + -- skip it if there are no @type members. + getCycleCheck n = [ + "CycleCheck<" ++ n ++ ">::Check();", + "CycleCheck<" ++ n ++ "> marker(*this);" + ] + categoryConstructor tm t ms = do + ctx <- getContextForInit tm t dd CategoryScope + initMembers <- runDataCompiler (sequence $ map compileLazyInit ms) ctx + let initMembersStr = intercalate ", " $ cdOutput initMembers + let initColon = if null initMembersStr then "" else " : " + mergeAllM [ + return $ onlyCode $ categoryName n ++ "()" ++ initColon ++ initMembersStr ++ " {", + return $ indentCompiled $ onlyCodes $ getCycleCheck (categoryName n), + return $ indentCompiled $ onlyCode $ startFunctionTracing $ show n ++ " (init @category)", + return $ onlyCode "}", + return $ clearCompiled initMembers -- Inherit required types. + ] + typeConstructor tm t ms = do + let ps = map vpParam $ getCategoryParams t + let argParent = categoryName n ++ "& p" + let paramsPassed = "Params<" ++ show (length ps) ++ ">::Type params" + let allArgs = intercalate ", " [argParent,paramsPassed] + let initParent = "parent(p)" + let initPassed = map (\(i,p) -> paramName p ++ "(*std::get<" ++ show i ++ ">(params))") $ zip [0..] ps + let allInit = intercalate ", " $ initParent:initPassed + ctx <- getContextForInit tm t dd TypeScope + initMembers <- runDataCompiler (sequence $ map initMember ms) ctx + mergeAllM [ + return $ onlyCode $ typeName n ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {", + return $ indentCompiled $ onlyCodes $ getCycleCheck (typeName n), + return $ indentCompiled $ onlyCode $ startFunctionTracing $ show n ++ " (init @type)", + return $ indentCompiled $ initMembers, + return $ onlyCode "}" + ] + valueConstructor tm t ms = do + let argParent = typeName n ++ "& p" + let paramsPassed = "const ParamTuple& params" + let argsPassed = "const ValueTuple& args" + let allArgs = intercalate ", " [argParent,paramsPassed,argsPassed] + let initParent = "parent(p)" + let initParams = map (\(i,p) -> paramName (vpParam p) ++ "(*params.At(" ++ show i ++ "))") $ zip [0..] pi + let initArgs = map (\(i,m) -> variableName (dmName m) ++ "(" ++ unwrappedArg i m ++ ")") $ zip [0..] ms + let allInit = intercalate ", " $ initParent:(initParams ++ initArgs) + return $ onlyCode $ valueName n ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" + unwrappedArg i m = writeStoredVariable (dmType m) (UnwrappedSingle $ "args.At(" ++ show i ++ ")") + createMember r filters m = do + validateGeneralInstance r filters (vtType $ dmType m) `reviseError` + ("In creation of " ++ show (dmName m) ++ " at " ++ formatFullContext (dmContext m)) + return $ onlyCode $ variableStoredType (dmType m) ++ " " ++ variableName (dmName m) ++ ";" + createMemberLazy r filters m = do + validateGeneralInstance r filters (vtType $ dmType m) `reviseError` + ("In creation of " ++ show (dmName m) ++ " at " ++ formatFullContext (dmContext m)) + return $ onlyCode $ variableLazyType (dmType m) ++ " " ++ variableName (dmName m) ++ ";" + initMember (DefinedMember _ _ _ _ Nothing) = return mergeDefault + initMember (DefinedMember c s t n (Just e)) = do + csAddVariable c n (VariableValue c s t True) + let assign = Assignment c (Positional [ExistingVariable (InputValue c n)]) e + compileStatement assign + categoryDispatch fs = + return $ onlyCodes $ [ + "ReturnTuple Dispatch(" ++ + "const CategoryFunction& label, " ++ + "const ParamTuple& params, " ++ + "const ValueTuple& args) final {" + ] ++ createFunctionDispatch n CategoryScope fs ++ ["}"] + typeDispatch fs = + return $ onlyCodes $ [ + "ReturnTuple Dispatch(" ++ + "const TypeFunction& label, " ++ + "const ParamTuple& params, " ++ + "const ValueTuple& args) final {" + ] ++ createFunctionDispatch n TypeScope fs ++ ["}"] + valueDispatch fs = + return $ onlyCodes $ [ + "ReturnTuple Dispatch(" ++ + "const S& self, " ++ + "const ValueFunction& label, " ++ + "const ParamTuple& params," ++ + "const ValueTuple& args) final {" + ] ++ createFunctionDispatch n ValueScope fs ++ ["}"] + +commonDefineAll :: MergeableM m => + AnyCategory c -> [Namespace] -> CompiledData [String] -> CompiledData [String] -> + CompiledData [String] -> CompiledData [String] -> + [ScopedFunction c] -> m CxxOutput +commonDefineAll t ns top bottom ce te fe = do + let filename = sourceFilename name + (CompiledData req out) <- fmap (addNamespace t) $ mergeAllM $ [ + return $ CompiledData (Set.fromList [name]) [], + return $ mergeAll [createCollection,createAllLabels] + ] ++ conditionalContent + let inherited = Set.fromList $ (map (tiName . vrType) $ getCategoryRefines t) ++ + (map (diName . vdType) $ getCategoryDefines t) + let includes = map (\i -> "#include \"" ++ headerFilename i ++ "\"") $ + filter (not . isBuiltinCategory) $ Set.toList $ Set.union req inherited + return $ CxxOutput (Just $ getCategoryName t) + filename + (getCategoryNamespace t) + ((getCategoryNamespace t):ns) + (filter (not . isBuiltinCategory) $ Set.toList req) + (baseSourceIncludes ++ includes ++ out) + where + conditionalContent + | isInstanceInterface t = [] + | otherwise = [ + return $ onlyCode $ "namespace {", + declareTypes, + declareInternalType name paramCount, + return top, + commonDefineCategory t ce, + return $ onlyCodes getInternal, + commonDefineType t te, + defineInternalType name paramCount, + return bottom, + return $ onlyCode $ "} // namespace", + return $ onlyCodes $ getCategory ++ getType + ] + declareTypes = + return $ onlyCodes $ map (\f -> "class " ++ f name ++ ";") [categoryName,typeName] + paramCount = length $ getCategoryParams t + name = getCategoryName t + createCollection = onlyCodes [ + "namespace {", + "const int " ++ collectionValName ++ " = 0;", + "} // namespace", + "const void* const " ++ collectionName name ++ " = &" ++ collectionValName ++ ";" + ] + collectionValName = "collection_" ++ show name + (fc,ft,fv) = partitionByScope sfScope $ getCategoryFunctions t ++ fe + createAllLabels = onlyCodes $ concat $ map createLabels [fc,ft,fv] + createLabels = map (uncurry createLabelForFunction) . zip [0..] . sortOn sfName . filter ((== name) . sfType) + getInternal = defineInternalCategory t + getCategory = defineGetCatetory t + getType = defineGetType t + +addNamespace :: AnyCategory c -> CompiledData [String] -> CompiledData [String] +addNamespace t cs + | isStaticNamespace $ getCategoryNamespace t = mergeAll [ + onlyCode $ "namespace " ++ show (getCategoryNamespace t) ++ " {", + cs, + onlyCode $ "} // namespace " ++ show (getCategoryNamespace t), + onlyCode $ "using namespace " ++ show (getCategoryNamespace t) ++ ";" + ] + | isDynamicNamespace $ getCategoryNamespace t = mergeAll [ + onlyCode $ "#ifdef " ++ dynamicNamespaceName, + onlyCode $ "namespace " ++ dynamicNamespaceName ++ " {", + onlyCode $ "#endif // " ++ dynamicNamespaceName, + cs, + onlyCode $ "#ifdef " ++ dynamicNamespaceName, + onlyCode $ "} // namespace " ++ dynamicNamespaceName, + onlyCode $ "using namespace " ++ dynamicNamespaceName ++ ";", + onlyCode $ "#endif // " ++ dynamicNamespaceName + ] + | otherwise = cs + +createLabelForFunction :: Int -> ScopedFunction c -> String +createLabelForFunction i f = functionLabelType f ++ " " ++ functionName f ++ + " = " ++ newFunctionLabel i f ++ ";" + +createFunctionDispatch :: CategoryName -> SymbolScope -> [ScopedFunction c] -> [String] +createFunctionDispatch n s fs = [typedef] ++ concat (map table $ byCategory) ++ + concat (map dispatch $ byCategory) ++ [fallback] where + filtered = filter ((== s) . sfScope) fs + flatten f = f:(concat $ map flatten $ sfMerges f) + flattened = concat $ map flatten filtered + byCategory = Map.toList $ Map.fromListWith (++) $ map (\f -> (sfType f,[f])) flattened + typedef + | s == CategoryScope = " using CallType = ReturnTuple(" ++ categoryName n ++ + "::*)(const ParamTuple&, const ValueTuple&);" + | s == TypeScope = " using CallType = ReturnTuple(" ++ typeName n ++ + "::*)(const ParamTuple&, const ValueTuple&);" + | s == ValueScope = " using CallType = ReturnTuple(" ++ valueName n ++ + "::*)(const S&, const ParamTuple&, const ValueTuple&);" + name f + | s == CategoryScope = categoryName n ++ "::" ++ callName f + | s == TypeScope = typeName n ++ "::" ++ callName f + | s == ValueScope = valueName n ++ "::" ++ callName f + table (n2,fs) = + [" static const CallType " ++ tableName n2 ++ "[] = {"] ++ + map (\f -> " &" ++ name f ++ ",") (Set.toList $ Set.fromList $ map sfName fs) ++ + [" };"] + dispatch (n2,fs) = [ + " if (label.collection == " ++ collectionName n2 ++ ") {", + " if (label.function_num < 0 || label.function_num >= " ++ show (length fs) ++ ") {", + " FAIL() << \"Bad function call \" << label;", + " }", + " return (this->*" ++ tableName n2 ++ "[label.function_num])(" ++ args ++ ");", + " }" + ] + args + | s == CategoryScope = "params, args" + | s == TypeScope = "params, args" + | s == ValueScope = "self, params, args" + fallback + | s == CategoryScope = " return TypeCategory::Dispatch(label, params, args);" + | s == TypeScope = " return TypeInstance::Dispatch(label, params, args);" + | s == ValueScope = " return TypeValue::Dispatch(self, label, params, args);" + +commonDefineCategory :: MergeableM m => + AnyCategory c -> CompiledData [String] -> m (CompiledData [String]) +commonDefineCategory t extra = do + mergeAllM $ [ + return $ onlyCode $ "struct " ++ categoryName name ++ " : public " ++ categoryBase ++ " {", + return $ indentCompiled $ defineCategoryName name, + return $ indentCompiled extra, + return $ onlyCode "};" + ] + where + name = getCategoryName t + +commonDefineType :: MergeableM m => + AnyCategory c -> CompiledData [String] -> m (CompiledData [String]) +commonDefineType t extra = do + mergeAllM [ + return $ CompiledData depends [], + return $ onlyCode $ "struct " ++ typeName (getCategoryName t) ++ " : public " ++ typeBase ++ " {", + return $ indentCompiled $ defineCategoryName2 name, + return $ indentCompiled $ defineTypeName name (map vpParam $ getCategoryParams t), + return $ indentCompiled $ onlyCode $ categoryName (getCategoryName t) ++ "& parent;", + return $ indentCompiled createParams, + return $ indentCompiled canConvertFrom, + return $ indentCompiled typeArgsForParent, + return $ indentCompiled extra, + return $ onlyCode "};" + ] + where + name = getCategoryName t + depends = getCategoryDeps t + createParams = mergeAll $ map createParam $ getCategoryParams t + createParam p = onlyCode $ paramType ++ " " ++ paramName (vpParam p) ++ ";" + canConvertFrom + | isInstanceInterface t = emptyCode + | otherwise = onlyCodes $ [ + "bool CanConvertFrom(const TypeInstance& from) const final {", + -- TODO: This should be a typedef. + " std::vector args;", + " if (!from.TypeArgsForParent(parent, args)) return false;", + -- TODO: Create a helper function for this error. + " if(args.size() != " ++ show (length params) ++ ") {", + " FAIL() << \"Wrong number of args (\" << args.size() << \") for \" << CategoryName();", + " }" + ] ++ checks ++ [" return true;","}"] + params = map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t + checks = concat $ map singleCheck $ zip [0..] params + singleCheck (i,(p,Covariant)) = [ + " if (!TypeInstance::CanConvert(*args[" ++ show i ++ "], " ++ paramName p ++ ")) return false;" + ] + singleCheck (i,(p,Contravariant)) = [ + " if (!TypeInstance::CanConvert(" ++ paramName p ++ ", *args[" ++ show i ++ "])) return false;" + ] + singleCheck (i,(p,Invariant)) = [ + " if (!TypeInstance::CanConvert(*args[" ++ show i ++ "], " ++ paramName p ++ ")) return false;", + " if (!TypeInstance::CanConvert(" ++ paramName p ++ ", *args[" ++ show i ++ "])) return false;" + ] + typeArgsForParent + | isInstanceInterface t = emptyCode + | otherwise = onlyCodes $ [ + "bool TypeArgsForParent(" ++ + "const TypeCategory& category, " ++ + "std::vector& args) const final {" + ] ++ allCats ++ [" return false;","}"] + myType = (getCategoryName t,map (SingleType . JustParamName . fst) params) + refines = map (\r -> (tiName r,pValues $ tiParams r)) $ map vrType $ getCategoryRefines t + allCats = concat $ map singleCat (myType:refines) + singleCat (t,ps) = [ + " if (&category == &" ++ categoryGetter t ++ "()) {", + " args = std::vector{" ++ expanded ++ "};", + " return true;", + " }" + ] + where + expanded = intercalate "," $ map ('&':) $ map expandLocalType ps + +-- Similar to Procedure.expandGeneralInstance but doesn't account for scope. +expandLocalType :: GeneralInstance -> String +expandLocalType (TypeMerge MergeUnion []) = allGetter ++ "()" +expandLocalType (TypeMerge MergeIntersect []) = anyGetter ++ "()" +expandLocalType (TypeMerge m ps) = + getter ++ "(L_get<" ++ typeBase ++ "*>(" ++ intercalate "," (map ("&" ++) ps') ++ "))" + where + ps' = map expandLocalType ps + getter + | m == MergeUnion = unionGetter + | m == MergeIntersect = intersectGetter +expandLocalType (SingleType (JustTypeInstance (TypeInstance t ps))) = + typeGetter t ++ "(T_get(" ++ intercalate "," (map ("&" ++) ps') ++ "))" + where + ps' = map expandLocalType $ pValues ps +expandLocalType (SingleType (JustParamName p)) = paramName p + +defineCategoryName :: CategoryName -> CompiledData [String] +defineCategoryName t = onlyCode $ "std::string CategoryName() const final { return \"" ++ show t ++ "\"; }" + +defineCategoryName2 :: CategoryName -> CompiledData [String] +defineCategoryName2 t = onlyCode $ "std::string CategoryName() const final { return parent.CategoryName(); }" + +defineTypeName :: CategoryName -> [ParamName] -> CompiledData [String] +defineTypeName t ps = + onlyCodes [ + "void BuildTypeName(std::ostream& output) const final {", + " return TypeInstance::TypeNameFrom(output, parent" ++ concat (map ((", " ++) . paramName) ps) ++ ");", + "}" + ] + +declareGetCategory :: AnyCategory c -> [String] +declareGetCategory t = [categoryBase ++ "& " ++ categoryGetter (getCategoryName t) ++ "();"] + +defineGetCatetory :: AnyCategory c -> [String] +defineGetCatetory t = [ + categoryBase ++ "& " ++ categoryGetter (getCategoryName t) ++ "() {", + " return " ++ categoryCreator (getCategoryName t) ++ "();", + "}" + ] + +declareGetType :: AnyCategory c -> [String] +declareGetType t = [typeBase ++ "& " ++ typeGetter (getCategoryName t) ++ "(Params<" ++ + show (length $getCategoryParams t) ++ ">::Type params);"] + +defineGetType :: AnyCategory c -> [String] +defineGetType t = [ + typeBase ++ "& " ++ typeGetter (getCategoryName t) ++ "(Params<" ++ + show (length $ getCategoryParams t) ++ ">::Type params) {", + " return " ++ typeCreator (getCategoryName t) ++ "(params);", + "}" + ] + +defineInternalCategory :: AnyCategory c -> [String] +defineInternalCategory t = [ + internal ++ "& " ++ categoryCreator (getCategoryName t) ++ "() {", + " static auto& category = *new " ++ internal ++ "();", + " return category;", + "}" + ] + where + internal = categoryName (getCategoryName t) + +declareInternalType :: Monad m => + CategoryName -> Int -> m (CompiledData [String]) +declareInternalType t n = + return $ onlyCode $ typeName t ++ "& " ++ typeCreator t ++ + "(Params<" ++ show n ++ ">::Type params);" + +defineInternalType :: Monad m => + CategoryName -> Int -> m (CompiledData [String]) +defineInternalType t n = return $ onlyCodes [ + typeName t ++ "& " ++ typeCreator t ++ "(Params<" ++ show n ++ ">::Type params) {", + " static auto& cache = *new InstanceMap<" ++ show n ++ "," ++ typeName t ++ ">();", + " auto& cached = cache[params];", + " if (!cached) { cached = R_get(new " ++ typeName t ++ "(" ++ categoryCreator t ++ "(), params)); }", + " return *cached;", + "}" + ] + +declareInternalValue :: Monad m => + CategoryName -> Int -> Int -> m (CompiledData [String]) +declareInternalValue t p n = + return $ onlyCodes [ + "S " ++ valueCreator t ++ + "(" ++ typeName t ++ "& parent, " ++ + "const ParamTuple& params, const ValueTuple& args);" + ] + +defineInternalValue :: Monad m => + CategoryName -> Int -> Int -> m (CompiledData [String]) +defineInternalValue t p n = + return $ onlyCodes [ + "S " ++ valueCreator t ++ "(" ++ typeName t ++ "& parent, " ++ + "const ParamTuple& params, const ValueTuple& args) {", + " return S_get(new " ++ valueName t ++ "(parent, params, args));", + "}" + ] + +createMainCommon :: String -> CompiledData [String] -> [String] +createMainCommon n (CompiledData req out) = + baseSourceIncludes ++ mainSourceIncludes ++ depIncludes req ++ [ + "int main(int argc, const char** argv) {", + " SetSignalHandler();", + " ProgramArgv program_argv(argc, argv);", + " " ++ startFunctionTracing n + ] ++ out ++ ["}"] where + depIncludes req = map (\i -> "#include \"" ++ headerFilename i ++ "\"") $ + filter (not . isBuiltinCategory) $ Set.toList req + +createMainFile :: (Show c, CompileErrorM m, MergeableM m) => + CategoryMap c -> CategoryName -> FunctionName -> m (Namespace,[String]) +createMainFile tm n f = flip reviseError ("In the creation of the main binary procedure") $ do + ca <- fmap indentCompiled (compileMainProcedure tm expr) + let file = createMainCommon "main" ca + (_,t) <- getConcreteCategory tm ([],n) + return (getCategoryNamespace t,file) where + funcCall = FunctionCall [] f (Positional []) (Positional []) + mainType = JustTypeInstance $ TypeInstance n (Positional []) + expr = Expression [] (TypeCall [] mainType funcCall) [] + +createTestFile :: (Show c, CompileErrorM m, MergeableM m) => + CategoryMap c -> Expression c -> m ([CategoryName],[String]) +createTestFile tm e = flip reviseError ("In the creation of the test binary procedure") $ do + ca@(CompiledData req _) <- fmap indentCompiled (compileMainProcedure tm e) + let file = createMainCommon "main" ca + return (filter (not . isBuiltinCategory) $ Set.toList req,file) diff --git a/src/CompilerCxx/CategoryContext.hs b/src/CompilerCxx/CategoryContext.hs new file mode 100644 --- /dev/null +++ b/src/CompilerCxx/CategoryContext.hs @@ -0,0 +1,162 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module CompilerCxx.CategoryContext ( + ScopeContext(..), + getContextForInit, + getMainContext, + getProcedureContext, +) where + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Base.CompileError +import Base.Mergeable +import Compilation.CompilerState +import Compilation.ProcedureContext +import Compilation.ScopeContext +import CompilerCxx.Code +import Types.DefinedCategory +import Types.Function +import Types.GeneralType +import Types.Positional +import Types.Procedure +import Types.TypeCategory +import Types.TypeInstance + + +getContextForInit :: (Show c, CompileErrorM m, MergeableM m) => + CategoryMap c -> AnyCategory c -> DefinedCategory c -> SymbolScope -> m (ProcedureContext c) +getContextForInit tm t d s = do + let ps = Positional $ getCategoryParams t + -- NOTE: This is always ValueScope for initializer checks. + let ms = filter ((== ValueScope) . dmScope) $ dcMembers d + let pa = if s == CategoryScope + then [] + else getCategoryFilters t + let sa = Map.fromList $ zip (map vpParam $ getCategoryParams t) (repeat TypeScope) + let r = CategoryResolver tm + fa <- setInternalFunctions r t (dcFunctions d) + let typeInstance = TypeInstance (getCategoryName t) $ fmap (SingleType . JustParamName . vpParam) ps + let builtin = Map.filter ((== LocalScope) . vvScope) $ builtinVariables typeInstance + -- Using < ensures that variables can only be referenced after initialization. + -- TODO: This doesn't really help if access is done via a function. + members <- mapMembers $ filter ((< s) . dmScope) (dcMembers d) + return $ ProcedureContext { + pcScope = s, + pcType = getCategoryName t, + pcExtParams = ps, + pcIntParams = Positional [], + pcMembers = ms, + pcCategories = tm, + pcAllFilters = getFilterMap (pValues ps) pa, + pcExtFilters = pa, + pcIntFilters = [], + pcParamScopes = sa, + pcFunctions = fa, + pcVariables = Map.union builtin members, + pcReturns = UnreachableCode, + pcPrimNamed = [], + pcRequiredTypes = Set.empty, + pcOutput = [], + pcDisallowInit = True, + pcLoopSetup = NotInLoop, + pcCleanupSetup = CleanupSetup [] [] + } + +getProcedureContext :: (Show c, CompileErrorM m, MergeableM m) => + ScopeContext c -> ScopedFunction c -> ExecutableProcedure c -> m (ProcedureContext c) +getProcedureContext (ScopeContext tm t ps pi ms pa fi fa va) + ff@(ScopedFunction _ _ _ s as1 rs1 ps1 fs _) + (ExecutableProcedure _ _ n as2 rs2 _) = do + rs' <- if isUnnamedReturns rs2 + then return $ ValidatePositions rs1 + else fmap (ValidateNames rs1 . Map.fromList) $ processPairs pairOutput rs1 (nrNames rs2) + va' <- updateArgVariables va as1 as2 + va'' <- updateReturnVariables va' rs1 rs2 + let pa' = if s == CategoryScope + then fs + else pa ++ fs + let localScopes = Map.fromList $ zip (map vpParam $ pValues ps1) (repeat LocalScope) + let typeScopes = Map.fromList $ zip (map vpParam $ pValues ps) (repeat TypeScope) + let valueScopes = Map.fromList $ zip (map vpParam $ pValues pi) (repeat ValueScope) + let sa = case s of + CategoryScope -> localScopes + TypeScope -> Map.union typeScopes localScopes + ValueScope -> Map.unions [localScopes,typeScopes,valueScopes] + let localFilters = getFunctionFilterMap ff + let typeFilters = getFilterMap (pValues ps) pa + let valueFilters = getFilterMap (pValues pi) fi + let allFilters = case s of + CategoryScope -> localFilters + TypeScope -> Map.union localFilters typeFilters + ValueScope -> Map.unions [localFilters,typeFilters,valueFilters] + let ns0 = if isUnnamedReturns rs2 + then [] + else zipWith3 ReturnVariable [0..] (map ovName $ pValues $ nrNames rs2) (map pvType $ pValues rs1) + let ns = filter (isPrimType . rvType) ns0 + return $ ProcedureContext { + pcScope = s, + pcType = t, + pcExtParams = ps, + pcIntParams = pi, + pcMembers = ms, + pcCategories = tm, + pcAllFilters = allFilters, + pcExtFilters = pa', + -- fs is duplicated so value initialization checks work properly. + pcIntFilters = fi ++ fs, + pcParamScopes = sa, + pcFunctions = fa, + pcVariables = va'', + pcReturns = rs', + pcPrimNamed = ns, + pcRequiredTypes = Set.empty, + pcOutput = [], + pcDisallowInit = False, + pcLoopSetup = NotInLoop, + pcCleanupSetup = CleanupSetup [] [] + } + where + pairOutput (PassedValue c1 t) (OutputValue c2 n) = return $ (n,PassedValue (c2++c1) t) + +getMainContext :: CompileErrorM m => CategoryMap c -> m (ProcedureContext c) +getMainContext tm = return $ ProcedureContext { + pcScope = LocalScope, + pcType = CategoryNone, + pcExtParams = Positional [], + pcIntParams = Positional [], + pcMembers = [], + pcCategories = tm, + pcAllFilters = Map.empty, + pcExtFilters = [], + pcIntFilters = [], + pcParamScopes = Map.empty, + pcFunctions = Map.empty, + pcVariables = Map.empty, + pcReturns = ValidatePositions (Positional []), + pcPrimNamed = [], + pcRequiredTypes = Set.empty, + pcOutput = [], + pcDisallowInit = False, + pcLoopSetup = NotInLoop, + pcCleanupSetup = CleanupSetup [] [] + } diff --git a/src/CompilerCxx/Code.hs b/src/CompilerCxx/Code.hs new file mode 100644 --- /dev/null +++ b/src/CompilerCxx/Code.hs @@ -0,0 +1,339 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module CompilerCxx.Code ( + ExprValue(..), + PrimitiveType(..), + categoryBase, + clearCompiled, + emptyCode, + escapeChar, + escapeChars, + functionLabelType, + indentCompiled, + isPrimType, + newFunctionLabel, + onlyCode, + onlyCodes, + paramType, + predTraceContext, + readStoredVariable, + setTraceContext, + startCleanupTracing, + startFunctionTracing, + typeBase, + useAsArgs, + useAsReturns, + useAsUnboxed, + useAsUnwrapped, + useAsWhatever, + valueAsUnwrapped, + valueAsWrapped, + valueBase, + variableLazyType, + variableProxyType, + variableStoredType, + writeStoredVariable, +) where + +import Data.Char +import Data.List (intercalate) +import qualified Data.Set as Set + +import Compilation.CompilerState +import CompilerCxx.Naming +import Types.Builtin +import Types.DefinedCategory +import Types.Positional +import Types.TypeCategory +import Types.TypeInstance + + +emptyCode :: CompiledData [String] +emptyCode = onlyCodes [] + +onlyCode :: String -> CompiledData [String] +onlyCode = onlyCodes . (:[]) + +onlyCodes :: [String] -> CompiledData [String] +onlyCodes = CompiledData Set.empty + +indentCompiled :: CompiledData [String] -> CompiledData [String] +indentCompiled (CompiledData r o) = CompiledData r $ map (" " ++) o + +clearCompiled :: CompiledData [String] -> CompiledData [String] +clearCompiled (CompiledData r _) = CompiledData r [] + +startFunctionTracing :: String -> String +startFunctionTracing f = "TRACE_FUNCTION(" ++ show f ++ ")" + +startCleanupTracing :: String +startCleanupTracing = "TRACE_CLEANUP" + +setTraceContext :: Show c => [c] -> [String] +setTraceContext c + | null c = [] + | otherwise = ["SET_CONTEXT_POINT(" ++ escapeChars (formatFullContext c) ++ ")"] + +predTraceContext :: Show c => [c] -> String +predTraceContext c + | null c = "" + | otherwise = "PRED_CONTEXT_POINT(" ++ escapeChars (formatFullContext c) ++ ")" + +data PrimitiveType = + PrimBool | + PrimString | + PrimChar | + PrimInt | + PrimFloat + deriving (Eq,Show) + +isPrimType :: ValueType -> Bool +isPrimType t + | t == boolRequiredValue = True + | t == intRequiredValue = True + | t == floatRequiredValue = True + | t == charRequiredValue = True + | otherwise = False + +data ExprValue = + OpaqueMulti String | + WrappedSingle String | + UnwrappedSingle String | + BoxedPrimitive PrimitiveType String | + UnboxedPrimitive PrimitiveType String | + LazySingle ExprValue + deriving (Show) + +getFromLazy (OpaqueMulti e) = OpaqueMulti $ e ++ ".Get()" +getFromLazy (WrappedSingle e) = WrappedSingle $ e ++ ".Get()" +getFromLazy (UnwrappedSingle e) = UnwrappedSingle $ e ++ ".Get()" +getFromLazy (BoxedPrimitive t e) = BoxedPrimitive t $ e ++ ".Get()" +getFromLazy (UnboxedPrimitive t e) = UnboxedPrimitive t $ e ++ ".Get()" +getFromLazy (LazySingle e) = LazySingle $ getFromLazy e + +useAsWhatever :: ExprValue -> String +useAsWhatever (OpaqueMulti e) = e +useAsWhatever (WrappedSingle e) = e +useAsWhatever (UnwrappedSingle e) = e +useAsWhatever (BoxedPrimitive _ e) = e +useAsWhatever (UnboxedPrimitive _ e) = e +useAsWhatever (LazySingle e) = useAsWhatever $ getFromLazy e + +useAsReturns :: ExprValue -> String +useAsReturns (OpaqueMulti e) = "(" ++ e ++ ")" +useAsReturns (WrappedSingle e) = "ReturnTuple(" ++ e ++ ")" +useAsReturns (UnwrappedSingle e) = "ReturnTuple(" ++ e ++ ")" +useAsReturns (BoxedPrimitive PrimBool e) = "ReturnTuple(Box_Bool(" ++ e ++ "))" +useAsReturns (BoxedPrimitive PrimString e) = "ReturnTuple(Box_String(" ++ e ++ "))" +useAsReturns (BoxedPrimitive PrimChar e) = "ReturnTuple(Box_Char(" ++ e ++ "))" +useAsReturns (BoxedPrimitive PrimInt e) = "ReturnTuple(Box_Int(" ++ e ++ "))" +useAsReturns (BoxedPrimitive PrimFloat e) = "ReturnTuple(Box_Float(" ++ e ++ "))" +useAsReturns (UnboxedPrimitive PrimBool e) = "ReturnTuple(Box_Bool(" ++ e ++ "))" +useAsReturns (UnboxedPrimitive PrimString e) = "ReturnTuple(Box_String(" ++ e ++ "))" +useAsReturns (UnboxedPrimitive PrimChar e) = "ReturnTuple(Box_Char(" ++ e ++ "))" +useAsReturns (UnboxedPrimitive PrimInt e) = "ReturnTuple(Box_Int(" ++ e ++ "))" +useAsReturns (UnboxedPrimitive PrimFloat e) = "ReturnTuple(Box_Float(" ++ e ++ "))" +useAsReturns (LazySingle e) = useAsReturns $ getFromLazy e + +useAsArgs :: ExprValue -> String +useAsArgs (OpaqueMulti e) = "(" ++ e ++ ")" +useAsArgs (WrappedSingle e) = "ArgTuple(" ++ e ++ ")" +useAsArgs (UnwrappedSingle e) = "ArgTuple(" ++ e ++ ")" +useAsArgs (BoxedPrimitive PrimBool e) = "ArgTuple(Box_Bool(" ++ e ++ "))" +useAsArgs (BoxedPrimitive PrimString e) = "ArgTuple(Box_String(" ++ e ++ "))" +useAsArgs (BoxedPrimitive PrimChar e) = "ArgTuple(Box_Char(" ++ e ++ "))" +useAsArgs (BoxedPrimitive PrimInt e) = "ArgTuple(Box_Int(" ++ e ++ "))" +useAsArgs (BoxedPrimitive PrimFloat e) = "ArgTuple(Box_Float(" ++ e ++ "))" +useAsArgs (UnboxedPrimitive PrimBool e) = "ArgTuple(Box_Bool(" ++ e ++ "))" +useAsArgs (UnboxedPrimitive PrimString e) = "ArgTuple(Box_String(" ++ e ++ "))" +useAsArgs (UnboxedPrimitive PrimChar e) = "ArgTuple(Box_Char(" ++ e ++ "))" +useAsArgs (UnboxedPrimitive PrimInt e) = "ArgTuple(Box_Int(" ++ e ++ "))" +useAsArgs (UnboxedPrimitive PrimFloat e) = "ArgTuple(Box_Float(" ++ e ++ "))" +useAsArgs (LazySingle e) = useAsArgs $ getFromLazy e + +useAsUnwrapped :: ExprValue -> String +useAsUnwrapped (OpaqueMulti e) = "(" ++ e ++ ").Only()" +useAsUnwrapped (WrappedSingle e) = "(" ++ e ++ ")" +useAsUnwrapped (UnwrappedSingle e) = "(" ++ e ++ ")" +useAsUnwrapped (BoxedPrimitive PrimBool e) = "Box_Bool(" ++ e ++ ")" +useAsUnwrapped (BoxedPrimitive PrimString e) = "Box_String(" ++ e ++ ")" +useAsUnwrapped (BoxedPrimitive PrimChar e) = "Box_Char(" ++ e ++ ")" +useAsUnwrapped (BoxedPrimitive PrimInt e) = "Box_Int(" ++ e ++ ")" +useAsUnwrapped (BoxedPrimitive PrimFloat e) = "Box_Float(" ++ e ++ ")" +useAsUnwrapped (UnboxedPrimitive PrimBool e) = "Box_Bool(" ++ e ++ ")" +useAsUnwrapped (UnboxedPrimitive PrimString e) = "Box_String(" ++ e ++ ")" +useAsUnwrapped (UnboxedPrimitive PrimChar e) = "Box_Char(" ++ e ++ ")" +useAsUnwrapped (UnboxedPrimitive PrimInt e) = "Box_Int(" ++ e ++ ")" +useAsUnwrapped (UnboxedPrimitive PrimFloat e) = "Box_Float(" ++ e ++ ")" +useAsUnwrapped (LazySingle e) = useAsUnwrapped $ getFromLazy e + +useAsUnboxed :: PrimitiveType -> ExprValue -> String +useAsUnboxed t (OpaqueMulti e) + | t == PrimBool = "(" ++ e ++ ").Only()->AsBool()" + | t == PrimString = "(" ++ e ++ ").Only()->AsString()" + | t == PrimChar = "(" ++ e ++ ").Only()->AsChar()" + | t == PrimInt = "(" ++ e ++ ").Only()->AsInt()" + | t == PrimFloat = "(" ++ e ++ ").Only()->AsFloat()" +useAsUnboxed t (WrappedSingle e) + | t == PrimBool = "(" ++ e ++ ")->AsBool()" + | t == PrimString = "(" ++ e ++ ")->AsString()" + | t == PrimChar = "(" ++ e ++ ")->AsChar()" + | t == PrimInt = "(" ++ e ++ ")->AsInt()" + | t == PrimFloat = "(" ++ e ++ ")->AsFloat()" +useAsUnboxed t (UnwrappedSingle e) + | t == PrimBool = "(" ++ e ++ ")->AsBool()" + | t == PrimString = "(" ++ e ++ ")->AsString()" + | t == PrimChar = "(" ++ e ++ ")->AsChar()" + | t == PrimInt = "(" ++ e ++ ")->AsInt()" + | t == PrimFloat = "(" ++ e ++ ")->AsFloat()" +useAsUnboxed _ (BoxedPrimitive _ e) = "(" ++ e ++ ")" +useAsUnboxed _ (UnboxedPrimitive _ e) = "(" ++ e ++ ")" +useAsUnboxed t (LazySingle e) = useAsUnboxed t $ getFromLazy e + +valueAsWrapped :: ExprValue -> ExprValue +valueAsWrapped (UnwrappedSingle e) = WrappedSingle e +valueAsWrapped (BoxedPrimitive _ e) = WrappedSingle e +valueAsWrapped (UnboxedPrimitive PrimBool e) = WrappedSingle $ "Box_Bool(" ++ e ++ ")" +valueAsWrapped (UnboxedPrimitive PrimString e) = WrappedSingle $ "Box_String(" ++ e ++ ")" +valueAsWrapped (UnboxedPrimitive PrimChar e) = WrappedSingle $ "Box_Char(" ++ e ++ ")" +valueAsWrapped (UnboxedPrimitive PrimInt e) = WrappedSingle $ "Box_Int(" ++ e ++ ")" +valueAsWrapped (UnboxedPrimitive PrimFloat e) = WrappedSingle $ "Box_Float(" ++ e ++ ")" +valueAsWrapped (LazySingle e) = valueAsWrapped $ getFromLazy e +valueAsWrapped v = v + +valueAsUnwrapped :: ExprValue -> ExprValue +valueAsUnwrapped (OpaqueMulti e) = UnwrappedSingle $ "(" ++ e ++ ").Only()" +valueAsUnwrapped (WrappedSingle e) = UnwrappedSingle e +valueAsUnwrapped (UnboxedPrimitive PrimBool e) = UnwrappedSingle $ "Box_Bool(" ++ e ++ ")" +valueAsUnwrapped (UnboxedPrimitive PrimString e) = UnwrappedSingle $ "Box_String(" ++ e ++ ")" +valueAsUnwrapped (UnboxedPrimitive PrimChar e) = UnwrappedSingle $ "Box_Char(" ++ e ++ ")" +valueAsUnwrapped (UnboxedPrimitive PrimInt e) = UnwrappedSingle $ "Box_Int(" ++ e ++ ")" +valueAsUnwrapped (UnboxedPrimitive PrimFloat e) = UnwrappedSingle $ "Box_Float(" ++ e ++ ")" +valueAsUnwrapped (LazySingle e) = valueAsUnwrapped $ getFromLazy e +valueAsUnwrapped v = v + +variableStoredType :: ValueType -> String +variableStoredType t + | t == boolRequiredValue = "bool" + | t == intRequiredValue = "PrimInt" + | t == floatRequiredValue = "PrimFloat" + | t == charRequiredValue = "PrimChar" + | isWeakValue t = "W" + | otherwise = "S" + +variableLazyType :: ValueType -> String +variableLazyType t = "LazyInit<" ++ variableStoredType t ++ ">" + +variableProxyType :: ValueType -> String +variableProxyType t + | t == boolRequiredValue = "bool" + | t == intRequiredValue = "PrimInt" + | t == floatRequiredValue = "PrimFloat" + | t == charRequiredValue = "PrimChar" + | isWeakValue t = "W&" + | otherwise = "S&" + +readStoredVariable :: Bool -> ValueType -> String -> ExprValue +readStoredVariable True t s = LazySingle $ readStoredVariable False t s +readStoredVariable False t s + | t == boolRequiredValue = UnboxedPrimitive PrimBool s + | t == intRequiredValue = UnboxedPrimitive PrimInt s + | t == floatRequiredValue = UnboxedPrimitive PrimFloat s + | t == charRequiredValue = UnboxedPrimitive PrimChar s + | otherwise = UnwrappedSingle s + +writeStoredVariable :: ValueType -> ExprValue -> String +writeStoredVariable t e + | t == boolRequiredValue = useAsUnboxed PrimBool e + | t == intRequiredValue = useAsUnboxed PrimInt e + | t == floatRequiredValue = useAsUnboxed PrimFloat e + | t == charRequiredValue = useAsUnboxed PrimChar e + | otherwise = useAsUnwrapped e + +functionLabelType :: ScopedFunction c -> String +functionLabelType = getType . sfScope where + getType CategoryScope = "const CategoryFunction&" + getType TypeScope = "const TypeFunction&" + getType ValueScope = "const ValueFunction&" + +newFunctionLabel :: Int -> ScopedFunction c -> String +newFunctionLabel i f = "(*new " ++ (getType $ sfScope f) ++ "{ " ++ intercalate ", " args ++ " })" where + args = [ + paramCount, + argCount, + returnCount, + category, + function, + collection, + functionNum + ] + paramCount = show $ length $ pValues $ sfParams f + argCount = show $ length $ pValues $ sfArgs f + returnCount = show $ length $ pValues $ sfReturns f + category = show $ show $ sfType f + function = show $ show $ sfName f + collection = collectionName $ sfType f + functionNum = show i + getType CategoryScope = "CategoryFunction" + getType TypeScope = "TypeFunction" + getType ValueScope = "ValueFunction" + + +categoryBase :: String +categoryBase = "TypeCategory" + +typeBase :: String +typeBase = "TypeInstance" + +valueBase :: String +valueBase = "TypeValue" + +paramType :: String +paramType = typeBase ++ "&" + +unescapedChars :: Set.Set Char +unescapedChars = Set.fromList $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ [' ','.'] + +escapeChar :: Char -> String +escapeChar c + | c `Set.member` unescapedChars = [c] + | otherwise = ['\\','x',asHex c1,asHex c2] where + c1 = (ord c) `div` 16 + c2 = (ord c) `mod` 16 + asHex n + | n < 10 = chr $ n + (ord '0') + | otherwise = chr $ n + (ord 'A') - 10 + +escapeChars :: String -> String +escapeChars cs + | null cs = "\"\"" + | otherwise = escapeAll False "" cs where + -- Creates alternating substrings of (un)escaped characters. + escapeAll False ss (c:cs) + | c `Set.member` unescapedChars = escapeAll False (ss ++ [c]) cs + | otherwise = maybeQuote ss ++ escapeAll True "" (c:cs) + escapeAll True ss (c:cs) + | c `Set.member` unescapedChars = maybeQuote ss ++ escapeAll False "" (c:cs) + | otherwise = escapeAll True (ss ++ escapeChar c) cs + escapeAll _ ss "" = maybeQuote ss + maybeQuote ss + | null ss = "" + | otherwise = "\"" ++ ss ++ "\"" diff --git a/src/CompilerCxx/Naming.hs b/src/CompilerCxx/Naming.hs new file mode 100644 --- /dev/null +++ b/src/CompilerCxx/Naming.hs @@ -0,0 +1,150 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module CompilerCxx.Naming ( + allGetter, + anyGetter, + baseHeaderIncludes, + baseSourceIncludes, + callName, + categoryCreator, + categoryGetter, + categoryName, + collectionName, + dynamicNamespaceName, + functionName, + headerFilename, + initializerName, + intersectGetter, + mainFilename, + mainSourceIncludes, + paramName, + privateNamespace, + publicNamespace, + qualifiedTypeGetter, + sourceFilename, + tableName, + typeCreator, + typeGetter, + typeName, + unionGetter, + valueCreator, + valueName, + variableName, +) where + +import Data.Hashable (Hashable,hash) +import Numeric (showHex) + +import Types.Function +import Types.Procedure +import Types.TypeCategory +import Types.TypeInstance + + +headerFilename :: CategoryName -> String +headerFilename n = "Category_" ++ show n ++ ".hpp" + +sourceFilename :: CategoryName -> String +sourceFilename n = "Category_" ++ show n ++ ".cpp" + +mainFilename :: String +mainFilename = "main.cpp" + +baseHeaderIncludes :: [String] +baseHeaderIncludes = ["#include \"category-header.hpp\""] + +baseSourceIncludes :: [String] +baseSourceIncludes = ["#include \"category-source.hpp\""] + +mainSourceIncludes :: [String] +mainSourceIncludes = ["#include \"argv.hpp\""] + +paramName :: ParamName -> String +paramName p = "Param_" ++ tail (pnName p) -- Remove leading '#'. + +variableName :: VariableName -> String +variableName v = "Var_" ++ show v + +initializerName :: VariableName -> String +initializerName v = "Init_" ++ show v + +categoryName :: CategoryName -> String +categoryName n = "Category_" ++ show n + +categoryGetter :: CategoryName -> String +categoryGetter n = "GetCategory_" ++ show n + +typeName :: CategoryName -> String +typeName n = "Type_" ++ show n + +typeGetter :: CategoryName -> String +typeGetter n = "GetType_" ++ show n + +intersectGetter :: String +intersectGetter = "Merge_Intersect" + +unionGetter:: String +unionGetter = "Merge_Union" + +allGetter :: String +allGetter = "GetMerged_All" + +anyGetter :: String +anyGetter = "GetMerged_Any" + +valueName :: CategoryName -> String +valueName n = "Value_" ++ show n + +callName :: FunctionName -> String +callName f = "Call_" ++ show f + +functionName :: ScopedFunction c -> String +functionName f = "Function_" ++ show (sfType f) ++ "_" ++ show (sfName f) + +collectionName :: CategoryName -> String +collectionName n = "Functions_" ++ show n + +tableName :: CategoryName -> String +tableName n = "Table_" ++ show n + +categoryCreator :: CategoryName -> String +categoryCreator n = "CreateCategory_" ++ show n + +typeCreator :: CategoryName -> String +typeCreator n = "CreateType_" ++ show n + +valueCreator :: CategoryName -> String +valueCreator n = "CreateValue_" ++ show n + +privateNamespace :: Hashable a => a -> String +privateNamespace = ("private_" ++) . flip showHex "" . abs . hash + +publicNamespace :: Hashable a => a -> String +publicNamespace = ("public_" ++) . flip showHex "" . abs . hash + +qualifiedTypeGetter :: AnyCategory c -> String +qualifiedTypeGetter t + | isStaticNamespace $ getCategoryNamespace t = + show (getCategoryNamespace t) ++ "::" ++ (typeGetter $ getCategoryName t) + | otherwise = typeGetter $ getCategoryName t + +dynamicNamespaceName :: String +dynamicNamespaceName = "ZEOLITE_DYNAMIC_NAMESPACE" diff --git a/src/CompilerCxx/Procedure.hs b/src/CompilerCxx/Procedure.hs new file mode 100644 --- /dev/null +++ b/src/CompilerCxx/Procedure.hs @@ -0,0 +1,868 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} + +module CompilerCxx.Procedure ( + compileExecutableProcedure, + compileMainProcedure, + compileExpression, + compileLazyInit, + compileStatement, +) where + +import Control.Applicative ((<|>)) +import Control.Monad (when) +import Control.Monad.Trans.State (execStateT,get,put,runStateT) +import Control.Monad.Trans (lift) +import Data.List (intercalate) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Base.CompileError +import Base.Mergeable +import Compilation.CompilerState +import CompilerCxx.CategoryContext +import CompilerCxx.Code +import CompilerCxx.Naming +import Types.Builtin +import Types.DefinedCategory +import Types.Function +import Types.GeneralType +import Types.Positional +import Types.Procedure +import Types.TypeCategory +import Types.TypeInstance + + +compileExecutableProcedure :: (Show c, CompileErrorM m, MergeableM m) => + ScopeContext c -> ScopedFunction c -> ExecutableProcedure c -> + m (CompiledData [String],CompiledData [String]) +compileExecutableProcedure ctx ff@(ScopedFunction _ _ _ s as1 rs1 ps1 _ _) + pp@(ExecutableProcedure _ c n as2 rs2 p) = do + ctx' <- getProcedureContext ctx ff pp + output <- runDataCompiler compileWithReturn ctx' + return (onlyCode header,wrapProcedure output) + where + t = scName ctx + compileWithReturn = do + ctx0 <- getCleanContext + compileProcedure ctx0 p >>= put + csRegisterReturn c Nothing `reviseErrorStateT` + ("In implicit return from " ++ show n ++ formatFullContextBrace c) + doNamedReturn + wrapProcedure output = + mergeAll $ [ + onlyCode header2, + indentCompiled $ onlyCode setProcedureTrace, + indentCompiled $ onlyCodes defineReturns, + indentCompiled $ onlyCodes nameParams, + indentCompiled $ onlyCodes nameArgs, + indentCompiled $ onlyCodes nameReturns, + indentCompiled output, + onlyCode close + ] + close = "}" + name = callName n + header + | s == ValueScope = + returnType ++ " " ++ name ++ + "(const S& Var_self, const ParamTuple& params, const ValueTuple& args);" + | otherwise = + returnType ++ " " ++ name ++ "(const ParamTuple& params, const ValueTuple& args);" + header2 + | s == CategoryScope = + returnType ++ " " ++ categoryName t ++ "::" ++ name ++ "(const ParamTuple& params, const ValueTuple& args) {" + | s == TypeScope = + returnType ++ " " ++ typeName t ++ "::" ++ name ++ "(const ParamTuple& params, const ValueTuple& args) {" + | s == ValueScope = + returnType ++ " " ++ valueName t ++ "::" ++ name ++ + "(const S& Var_self, const ParamTuple& params, const ValueTuple& args) {" + returnType = "ReturnTuple" + setProcedureTrace = startFunctionTracing $ show t ++ "." ++ show n + defineReturns = [returnType ++ " returns(" ++ show (length $ pValues rs1) ++ ");"] + nameParams = flip map (zip [0..] $ pValues ps1) $ + (\(i,p) -> paramType ++ " " ++ paramName (vpParam p) ++ " = *params.At(" ++ show i ++ ");") + nameArgs = flip map (zip [0..] $ filter (not . isDiscardedInput . snd) $ zip (pValues as1) (pValues $ avNames as2)) $ + (\(i,(t,n)) -> "const " ++ variableProxyType (pvType t) ++ " " ++ variableName (ivName n) ++ + " = " ++ writeStoredVariable (pvType t) (UnwrappedSingle $ "args.At(" ++ show i ++ ")") ++ ";") + nameReturns + | isUnnamedReturns rs2 = [] + | otherwise = map (\(i,(t,n)) -> nameReturn i (pvType t) n) (zip [0..] $ zip (pValues rs1) (pValues $ nrNames rs2)) + nameReturn i t n + | isPrimType t = variableProxyType t ++ " " ++ variableName (ovName n) ++ ";" + | otherwise = + variableProxyType t ++ " " ++ variableName (ovName n) ++ + " = " ++ writeStoredVariable t (UnwrappedSingle $ "returns.At(" ++ show i ++ ")") ++ ";" + +compileCondition :: (Show c, CompileErrorM m, MergeableM m, + CompilerContext c m [String] a) => + a -> [c] -> Expression c -> CompilerState a m String +compileCondition ctx c e = do + (e',ctx') <- lift $ runStateT compile ctx + lift (ccGetRequired ctx') >>= csRequiresTypes + return $ predTraceContext c ++ e' + where + compile = flip reviseErrorStateT ("In condition at " ++ formatFullContext c) $ do + (ts,e') <- compileExpression e + lift $ checkCondition ts + return $ useAsUnboxed PrimBool e' + where + checkCondition (Positional [t]) | t == boolRequiredValue = return () + checkCondition (Positional ts) = + compileError $ "Conditionals must have exactly one Bool return but found {" ++ + intercalate "," (map show ts) ++ "}" + +-- Returns the state so that returns can be properly checked for if/elif/else. +compileProcedure :: (Show c, CompileErrorM m, MergeableM m, + CompilerContext c m [String] a) => + a -> Procedure c -> CompilerState a m a +compileProcedure ctx (Procedure c ss) = do + ctx' <- lift $ execStateT (sequence $ map (\s -> warnUnreachable s >> compileStatement s) ss) ctx + return ctx' where + warnUnreachable s = do + unreachable <- csIsUnreachable + lift $ when unreachable $ + compileWarningM $ "Statement at " ++ + formatFullContext (getStatementContext s) ++ + " is unreachable" + +compileStatement :: (Show c, CompileErrorM m, MergeableM m, + CompilerContext c m [String] a) => + Statement c -> CompilerState a m () +compileStatement (EmptyReturn c) = do + csRegisterReturn c Nothing + csWrite $ setTraceContext c + doNamedReturn +compileStatement (ExplicitReturn c es) = do + es' <- sequence $ map compileExpression $ pValues es + getReturn $ zip (map getExpressionContext $ pValues es) es' + where + -- Single expression, but possibly multi-return. + getReturn [(_,(Positional ts,e))] = do + csRegisterReturn c $ Just (Positional ts) + csWrite $ setTraceContext c + csWrite ["returns = " ++ useAsReturns e ++ ";"] + doReturnCleanup + csWrite ["return returns;"] + -- Multi-expression => must all be singles. + getReturn rs = do + lift $ mergeAllM (map checkArity $ zip [1..] $ map (fst . snd) rs) `reviseError` + ("In return at " ++ formatFullContext c) + csRegisterReturn c $ Just $ Positional $ map (head . pValues . fst . snd) rs + csWrite $ concat $ map bindReturn $ zip [0..] rs + doReturnCleanup + csWrite ["return returns;"] + checkArity (_,Positional [_]) = return () + checkArity (i,Positional ts) = + compileError $ "Return position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1" + bindReturn (i,(c0,(_,e))) = setTraceContext c0 ++ [ + "returns.At(" ++ show i ++ ") = " ++ useAsUnwrapped e ++ ";" + ] +compileStatement (LoopBreak c) = do + loop <- csGetLoop + case loop of + NotInLoop -> + lift $ compileError $ "Using break outside of while is no allowed" ++ formatFullContextBrace c + _ -> return () + csWrite ["break;"] +compileStatement (LoopContinue c) = do + loop <- csGetLoop + case loop of + NotInLoop -> + lift $ compileError $ "Using continue outside of while is no allowed" ++ formatFullContextBrace c + _ -> return () + csWrite $ ["{"] ++ lsUpdate loop ++ ["}","continue;"] +compileStatement (FailCall c e) = do + e' <- compileExpression e + when (length (pValues $ fst e') /= 1) $ + lift $ compileError $ "Expected single return in argument" ++ formatFullContextBrace c + let (Positional [t0],e) = e' + r <- csResolver + fa <- csAllFilters + lift $ (checkValueTypeMatch r fa t0 formattedRequiredValue) `reviseError` + ("In fail call at " ++ formatFullContext c) + csSetNoReturn + csWrite $ setTraceContext c + csWrite ["BuiltinFail(" ++ useAsUnwrapped e ++ ");"] +compileStatement (IgnoreValues c e) = do + (_,e') <- compileExpression e + csWrite $ setTraceContext c + csWrite ["(void) (" ++ useAsWhatever e' ++ ");"] +compileStatement (Assignment c as e) = do + (ts,e') <- compileExpression e + r <- csResolver + fa <- csAllFilters + processPairsT (createVariable r fa) as ts `reviseErrorStateT` + ("In assignment at " ++ formatFullContext c) + csWrite $ setTraceContext c + variableTypes <- sequence $ map (uncurry getVariableType) $ zip (pValues as) (pValues ts) + assignAll (zip3 [0..] variableTypes (pValues as)) e' + where + assignAll [v] e = assignSingle v e + assignAll vs e = do + csWrite ["{","const auto r = " ++ useAsReturns e ++ ";"] + sequence $ map assignMulti vs + csWrite ["}"] + getVariableType (CreateVariable _ t _) _ = return t + getVariableType (ExistingVariable (InputValue c n)) _ = do + (VariableValue _ _ t _) <- csGetVariable c n + return t + getVariableType (ExistingVariable (DiscardInput _)) t = return t + createVariable r fa (CreateVariable c t1 n) t2 = do + -- TODO: Call csRequiresTypes for t1. (Maybe needs a helper function.) + lift $ mergeAllM [validateGeneralInstance r fa (vtType t1), + checkValueTypeMatch r fa t2 t1] `reviseError` + ("In creation of " ++ show n ++ " at " ++ formatFullContext c) + csAddVariable c n (VariableValue c LocalScope t1 True) + csWrite [variableStoredType t1 ++ " " ++ variableName n ++ ";"] + createVariable r fa (ExistingVariable (InputValue c n)) t2 = do + (VariableValue _ s1 t1 w) <- csGetVariable c n + when (not w) $ lift $ compileError $ "Cannot assign to read-only variable " ++ + show n ++ formatFullContextBrace c + -- TODO: Also show original context. + lift $ (checkValueTypeMatch r fa t2 t1) `reviseError` + ("In assignment to " ++ show n ++ " at " ++ formatFullContext c) + csUpdateAssigned n + createVariable _ _ _ _ = return () + assignSingle (i,t,CreateVariable _ _ n) e = + csWrite [variableName n ++ " = " ++ writeStoredVariable t e ++ ";"] + assignSingle (i,t,ExistingVariable (InputValue _ n)) e = do + (VariableValue _ s _ _) <- csGetVariable c n + scoped <- autoScope s + csWrite [scoped ++ variableName n ++ " = " ++ writeStoredVariable t e ++ ";"] + assignSingle _ _ = return () + assignMulti (i,t,CreateVariable _ _ n) = + csWrite [variableName n ++ " = " ++ + writeStoredVariable t (UnwrappedSingle $ "r.At(" ++ show i ++ ")") ++ ";"] + assignMulti (i,t,ExistingVariable (InputValue _ n)) = do + (VariableValue _ s _ _) <- csGetVariable c n + scoped <- autoScope s + csWrite [scoped ++ variableName n ++ " = " ++ + writeStoredVariable t (UnwrappedSingle $ "r.At(" ++ show i ++ ")") ++ ";"] + assignMulti _ = return () +compileStatement (NoValueExpression _ v) = compileVoidExpression v + +compileLazyInit :: (Show c, CompileErrorM m, MergeableM m, + CompilerContext c m [String] a) => + DefinedMember c -> CompilerState a m () +compileLazyInit (DefinedMember _ _ _ _ Nothing) = return mergeDefault +compileLazyInit (DefinedMember c _ t1 n (Just e)) = do + (ts,e') <- compileExpression e + when (length (pValues ts) /= 1) $ + lift $ compileError $ "Expected single return in initializer" ++ formatFullContextBrace (getExpressionContext e) + r <- csResolver + fa <- csAllFilters + let Positional [t2] = ts + lift $ (checkValueTypeMatch r fa t2 t1) `reviseError` + ("In initialization of " ++ show n ++ " at " ++ formatFullContext c) + csWrite [variableName n ++ "([]() { return " ++ writeStoredVariable t1 e' ++ "; })"] + +compileVoidExpression :: (Show c, CompileErrorM m, MergeableM m, + CompilerContext c m [String] a) => + VoidExpression c -> CompilerState a m () +compileVoidExpression (Conditional ie) = compileIfElifElse ie +compileVoidExpression (Loop l) = compileWhileLoop l +compileVoidExpression (WithScope s) = compileScopedBlock s +compileVoidExpression (LineComment s) = csWrite $ map ("// " ++) $ lines s +compileVoidExpression (Unconditional p) = do + ctx0 <- getCleanContext + ctx <- compileProcedure ctx0 p + (lift $ ccGetRequired ctx) >>= csRequiresTypes + csWrite ["{"] + (lift $ ccGetOutput ctx) >>= csWrite + csWrite ["}"] + csInheritReturns [ctx] + +compileIfElifElse :: (Show c, CompileErrorM m, MergeableM m, + CompilerContext c m [String] a) => + IfElifElse c -> CompilerState a m () +compileIfElifElse (IfStatement c e p es) = do + ctx0 <- getCleanContext + e' <- compileCondition ctx0 c e + ctx <- compileProcedure ctx0 p + (lift $ ccGetRequired ctx) >>= csRequiresTypes + csWrite ["if (" ++ e' ++ ") {"] + (lift $ ccGetOutput ctx) >>= csWrite + csWrite ["}"] + cs <- unwind es + csInheritReturns (ctx:cs) + where + unwind (IfStatement c e p es) = do + ctx0 <- getCleanContext + e' <- compileCondition ctx0 c e + ctx <- compileProcedure ctx0 p + (lift $ ccGetRequired ctx) >>= csRequiresTypes + csWrite ["else if (" ++ e' ++ ") {"] + (lift $ ccGetOutput ctx) >>= csWrite + csWrite ["}"] + cs <- unwind es + return $ ctx:cs + unwind (ElseStatement c p) = do + ctx0 <- getCleanContext + ctx <- compileProcedure ctx0 p + (lift $ ccGetRequired ctx) >>= csRequiresTypes + csWrite ["else {"] + (lift $ ccGetOutput ctx) >>= csWrite + csWrite ["}"] + return [ctx] + unwind TerminateConditional = fmap (:[]) get + +compileWhileLoop :: (Show c, CompileErrorM m, MergeableM m, + CompilerContext c m [String] a) => + WhileLoop c -> CompilerState a m () +compileWhileLoop (WhileLoop c e p u) = do + ctx0 <- getCleanContext + e' <- compileCondition ctx0 c e + ctx0' <- case u of + Just p2 -> do + ctx1 <- lift $ ccStartLoop ctx0 (LoopSetup []) + ctx2 <- compileProcedure ctx1 p2 + (lift $ ccGetRequired ctx2) >>= csRequiresTypes + p2' <- lift $ ccGetOutput ctx2 + lift $ ccStartLoop ctx0 (LoopSetup p2') + _ -> lift $ ccStartLoop ctx0 (LoopSetup []) + (LoopSetup u') <- lift $ ccGetLoop ctx0' + ctx <- compileProcedure ctx0' p + (lift $ ccGetRequired ctx) >>= csRequiresTypes + csWrite ["while (" ++ e' ++ ") {"] + (lift $ ccGetOutput ctx) >>= csWrite + csWrite $ ["{"] ++ u' ++ ["}"] + csWrite ["}"] + +compileScopedBlock :: (Show c, CompileErrorM m, MergeableM m, + CompilerContext c m [String] a) => + ScopedBlock c -> CompilerState a m () +compileScopedBlock s = do + let (vs,p,cl,st) = rewriteScoped s + -- Capture context so we can discard scoped variable names. + ctx0 <- getCleanContext + r <- csResolver + fa <- csAllFilters + let cc = case cl of + Just (Procedure _ ss2) -> ss2 + _ -> [] + sequence $ map (createVariable r fa) vs + ctxP <- compileProcedure ctx0 p + (ctxP',cl',ctxCl) <- + case cl of + Just p2 -> do + ctx0' <- lift $ ccClearOutput ctxP + ctxCl <- compileProcedure ctx0' p2 + p2' <- lift $ ccGetOutput ctxCl + -- TODO: It might be helpful to add a new trace-context line for this + -- so that the line that triggered the cleanup is still in the trace. + let p2'' = ["{",startCleanupTracing] ++ p2' ++ ["}"] + ctxP' <- lift $ ccPushCleanup ctxP (CleanupSetup [ctxCl] p2'') + return (ctxP',p2'',ctxCl) + Nothing -> return (ctxP,[],ctxP) + -- Make variables to be created visible *after* p has been compiled so that p + -- can't refer to them. + ctxP'' <- lift $ execStateT (sequence $ map showVariable vs) ctxP' + ctxS <- compileProcedure ctxP'' (Procedure [] [st]) + csWrite ["{"] + (lift $ ccGetOutput ctxS) >>= csWrite + csWrite cl' + csWrite ["}"] + sequence $ map showVariable vs + (lift $ ccGetRequired ctxS) >>= csRequiresTypes + (lift $ ccGetRequired ctxCl) >>= csRequiresTypes + csInheritReturns [ctxS] + csInheritReturns [ctxCl] + where + createVariable r fa (c,t,n) = do + lift $ validateGeneralInstance r fa (vtType t) `reviseError` + ("In creation of " ++ show n ++ " at " ++ formatFullContext c) + csWrite [variableStoredType t ++ " " ++ variableName n ++ ";"] + showVariable (c,t,n) = do + -- TODO: Call csRequiresTypes for t. (Maybe needs a helper function.) + csAddVariable c n (VariableValue c LocalScope t True) + -- Don't merge if the second scope has cleanup, so that the latter can't + -- refer to variables defined in the first scope. + rewriteScoped (ScopedBlock c p cl@(Just _) + s@(NoValueExpression _ (WithScope + (ScopedBlock _ _ (Just _) _)))) = + ([],p,cl,s) + -- Merge chained scoped sections into a single section. + rewriteScoped (ScopedBlock c (Procedure c2 ss1) cl1 + (NoValueExpression _ (WithScope + (ScopedBlock _ (Procedure _ ss2) cl2 s)))) = + rewriteScoped $ ScopedBlock c (Procedure c2 $ ss1 ++ ss2) (cl1 <|> cl2) s + -- Gather to-be-created variables. + rewriteScoped (ScopedBlock _ p cl (Assignment c2 vs e)) = + (created,p,cl,Assignment c2 (Positional existing) e) where + (created,existing) = foldr update ([],[]) (pValues vs) + update (CreateVariable c t n) (cs,es) = ((c,t,n):cs,(ExistingVariable $ InputValue c n):es) + update e (cs,es) = (cs,e:es) + -- Merge the statement into the scoped block. + rewriteScoped (ScopedBlock _ p cl s) = + ([],p,cl,s) + +compileExpression :: (Show c, CompileErrorM m, MergeableM m, + CompilerContext c m [String] a) => + Expression c -> CompilerState a m (ExpressionType,ExprValue) +compileExpression = compile where + compile (Literal (StringLiteral c l)) = do + return (Positional [stringRequiredValue],UnboxedPrimitive PrimString $ "PrimString_FromLiteral(" ++ escapeChars l ++ ")") + compile (Literal (CharLiteral c l)) = do + return (Positional [charRequiredValue],UnboxedPrimitive PrimChar $ "PrimChar('" ++ escapeChar l ++ "')") + compile (Literal (IntegerLiteral c True l)) = do + when (l > 2^64 - 1) $ lift $ compileError $ + "Literal " ++ show l ++ formatFullContextBrace c ++ " is greater than the max value for 64-bit unsigned" + let l' = if l > 2^63 - 1 then l - 2^64 else l + return (Positional [intRequiredValue],UnboxedPrimitive PrimInt $ "PrimInt(" ++ show l' ++ ")") + compile (Literal (IntegerLiteral c False l)) = do + when (l > 2^63 - 1) $ lift $ compileError $ + "Literal " ++ show l ++ formatFullContextBrace c ++ " is greater than the max value for 64-bit signed" + when ((-l) > 2^63 - 2) $ lift $ compileError $ + "Literal " ++ show l ++ formatFullContextBrace c ++ " is less than the min value for 64-bit signed" + return (Positional [intRequiredValue],UnboxedPrimitive PrimInt $ "PrimInt(" ++ show l ++ ")") + compile (Literal (DecimalLiteral c l e)) = do + -- TODO: Check bounds. + return (Positional [floatRequiredValue],UnboxedPrimitive PrimFloat $ "PrimFloat(" ++ show l ++ "E" ++ show e ++ ")") + compile (Literal (BoolLiteral c True)) = do + return (Positional [boolRequiredValue],UnboxedPrimitive PrimBool "true") + compile (Literal (BoolLiteral c False)) = do + return (Positional [boolRequiredValue],UnboxedPrimitive PrimBool "false") + compile (Literal (EmptyLiteral c)) = do + return (Positional [emptyValue],UnwrappedSingle "Var_empty") + compile (Expression c s os) = do + foldl transform (compileExpressionStart s) os + compile (UnaryExpression c (FunctionOperator _ (FunctionSpec _ (CategoryFunction c2 cn) fn ps)) e) = + compile (Expression c (CategoryCall c2 cn (FunctionCall c fn ps (Positional [e]))) []) + compile (UnaryExpression c (FunctionOperator _ (FunctionSpec _ (TypeFunction c2 tn) fn ps)) e) = + compile (Expression c (TypeCall c2 tn (FunctionCall c fn ps (Positional [e]))) []) + compile (UnaryExpression c (FunctionOperator _ (FunctionSpec _ (ValueFunction c2 e0) fn ps)) e) = + compile (Expression c (ParensExpression c2 e0) [ValueCall c (FunctionCall c fn ps (Positional [e]))]) + compile (UnaryExpression c (FunctionOperator _ (FunctionSpec c2 UnqualifiedFunction fn ps)) e) = + compile (Expression c (UnqualifiedCall c2 (FunctionCall c fn ps (Positional [e]))) []) + compile (UnaryExpression c (NamedOperator "-") (Literal (IntegerLiteral _ _ l))) = + compile (Literal (IntegerLiteral c False (-l))) + compile (UnaryExpression c (NamedOperator "-") (Literal (DecimalLiteral _ l e))) = + compile (Literal (DecimalLiteral c (-l) e)) + compile (UnaryExpression c (NamedOperator o) e) = do + (Positional ts,e') <- compileExpression e + t' <- requireSingle c ts + doUnary t' e' + where + doUnary t e + | o == "!" = doNot t e + | o == "-" = doNeg t e + | otherwise = lift $ compileError $ "Unknown unary operator \"" ++ o ++ "\" " ++ + formatFullContextBrace c + doNot t e = do + when (t /= boolRequiredValue) $ + lift $ compileError $ "Cannot use " ++ show t ++ " with unary ! operator" ++ + formatFullContextBrace c + return $ (Positional [boolRequiredValue],UnboxedPrimitive PrimBool $ "!" ++ useAsUnboxed PrimBool e) + doNeg t e + | t == intRequiredValue = return $ (Positional [intRequiredValue], + UnboxedPrimitive PrimInt $ "-" ++ useAsUnboxed PrimInt e) + | t == floatRequiredValue = return $ (Positional [floatRequiredValue], + UnboxedPrimitive PrimFloat $ "-" ++ useAsUnboxed PrimFloat e) + | otherwise = lift $ compileError $ "Cannot use " ++ show t ++ " with unary - operator" ++ + formatFullContextBrace c + compile (InitializeValue c t ps es) = do + es' <- sequence $ map compileExpression $ pValues es + (ts,es'') <- getValues es' + csCheckValueInit c t (Positional ts) ps + params <- expandParams $ tiParams t + params2 <- expandParams2 $ ps + sameType <- csSameType t + s <- csCurrentScope + let typeInstance = getType sameType s params + -- TODO: This is unsafe if used in a type or category constructor. + return (Positional [ValueType RequiredValue $ SingleType $ JustTypeInstance t], + UnwrappedSingle $ valueCreator (tiName t) ++ "(" ++ typeInstance ++ ", " ++ params2 ++ ", " ++ es'' ++ ")") + where + getType True TypeScope _ = "*this" + getType True ValueScope _ = "parent" + getType _ _ params = typeCreator (tiName t) ++ "(" ++ params ++ ")" + -- Single expression, but possibly multi-return. + getValues [(Positional ts,e)] = return (ts,useAsArgs e) + -- Multi-expression => must all be singles. + getValues rs = do + lift $ mergeAllM (map checkArity $ zip [1..] $ map fst rs) `reviseError` + ("In return at " ++ formatFullContext c) + return (map (head . pValues . fst) rs, + "ArgTuple(" ++ intercalate ", " (map (useAsUnwrapped . snd) rs) ++ ")") + checkArity (_,Positional [_]) = return () + checkArity (i,Positional ts) = + compileError $ "Initializer position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1" + compile (InfixExpression c e1 (FunctionOperator _ (FunctionSpec _ (CategoryFunction c2 cn) fn ps)) e2) = + compile (Expression c (CategoryCall c2 cn (FunctionCall c fn ps (Positional [e1,e2]))) []) + compile (InfixExpression c e1 (FunctionOperator _ (FunctionSpec _ (TypeFunction c2 tn) fn ps)) e2) = + compile (Expression c (TypeCall c2 tn (FunctionCall c fn ps (Positional [e1,e2]))) []) + compile (InfixExpression c e1 (FunctionOperator _ (FunctionSpec _ (ValueFunction c2 e0) fn ps)) e2) = + compile (Expression c (ParensExpression c2 e0) [ValueCall c (FunctionCall c fn ps (Positional [e1,e2]))]) + compile (InfixExpression c e1 (FunctionOperator _ (FunctionSpec c2 UnqualifiedFunction fn ps)) e2) = + compile (Expression c (UnqualifiedCall c2 (FunctionCall c fn ps (Positional [e1,e2]))) []) + compile (InfixExpression c e1 (NamedOperator o) e2) = do + e1' <- compileExpression e1 + e2' <- if o `Set.member` logical + then isolateExpression e2 -- Ignore named-return assignments. + else compileExpression e2 + bindInfix c e1' o e2' + isolateExpression e = do + ctx <- getCleanContext + (e',ctx') <- lift $ runStateT (compileExpression e) ctx + (lift $ ccGetRequired ctx') >>= csRequiresTypes + return e' + arithmetic1 = Set.fromList ["*","/"] + arithmetic2 = Set.fromList ["%"] + arithmetic3 = Set.fromList ["+","-"] + arithmetic = Set.union arithmetic1 arithmetic2 + equals = Set.fromList ["==","!="] + comparison = Set.fromList ["==","!=","<","<=",">",">="] + logical = Set.fromList ["&&","||"] + bindInfix c (Positional ts1,e1) o (Positional ts2,e2) = do + -- TODO: Needs better error messages. + t1' <- requireSingle c ts1 + t2' <- requireSingle c ts2 + bind t1' t2' + where + bind t1 t2 + | t1 /= t2 = + lift $ compileError $ "Cannot " ++ show o ++ " " ++ show t1 ++ " and " ++ + show t2 ++ formatFullContextBrace c + | o `Set.member` comparison && t1 == intRequiredValue = do + return (Positional [boolRequiredValue],glueInfix PrimInt PrimBool e1 o e2) + | o `Set.member` comparison && t1 == floatRequiredValue = do + return (Positional [boolRequiredValue],glueInfix PrimFloat PrimBool e1 o e2) + | o `Set.member` comparison && t1 == stringRequiredValue = do + return (Positional [boolRequiredValue],glueInfix PrimString PrimBool e1 o e2) + | o `Set.member` comparison && t1 == charRequiredValue = do + return (Positional [boolRequiredValue],glueInfix PrimChar PrimBool e1 o e2) + | o `Set.member` arithmetic1 && t1 == intRequiredValue = do + return (Positional [intRequiredValue],glueInfix PrimInt PrimInt e1 o e2) + | o `Set.member` arithmetic2 && t1 == intRequiredValue = do + return (Positional [intRequiredValue],glueInfix PrimInt PrimInt e1 o e2) + | o `Set.member` arithmetic3 && t1 == intRequiredValue = do + return (Positional [intRequiredValue],glueInfix PrimInt PrimInt e1 o e2) + | o `Set.member` arithmetic1 && t1 == floatRequiredValue = do + return (Positional [floatRequiredValue],glueInfix PrimFloat PrimFloat e1 o e2) + | o `Set.member` arithmetic3 && t1 == floatRequiredValue = do + return (Positional [floatRequiredValue],glueInfix PrimFloat PrimFloat e1 o e2) + | o == "+" && t1 == stringRequiredValue = do + return (Positional [stringRequiredValue],glueInfix PrimString PrimString e1 o e2) + | o `Set.member` logical && t1 == boolRequiredValue = do + return (Positional [boolRequiredValue],glueInfix PrimBool PrimBool e1 o e2) + | o == "-" && t1 == charRequiredValue = do + return (Positional [intRequiredValue],glueInfix PrimChar PrimInt e1 o e2) + | o `Set.member` equals && t1 == boolRequiredValue = do + return (Positional [boolRequiredValue],glueInfix PrimBool PrimBool e1 o e2) + | otherwise = + lift $ compileError $ "Cannot " ++ show o ++ " " ++ show t1 ++ " and " ++ + show t2 ++ formatFullContextBrace c + glueInfix t1 t2 e1 o e2 = + UnboxedPrimitive t2 $ useAsUnboxed t1 e1 ++ o ++ useAsUnboxed t1 e2 + transform e (ConvertedCall c t f) = do + (Positional ts,e') <- e + t' <- requireSingle c ts + r <- csResolver + fa <- csAllFilters + let vt = ValueType RequiredValue $ SingleType $ JustTypeInstance t + lift $ (checkValueTypeMatch r fa t' vt) `reviseError` + ("In conversion at " ++ formatFullContext c) + f' <- lookupValueFunction vt f + compileFunctionCall (Just $ useAsUnwrapped e') f' f + transform e (ValueCall c f) = do + (Positional ts,e') <- e + t' <- requireSingle c ts + f' <- lookupValueFunction t' f + compileFunctionCall (Just $ useAsUnwrapped e') f' f + requireSingle c [t] = return t + requireSingle c ts = + lift $ compileError $ "Function call requires 1 return but found but found {" ++ + intercalate "," (map show ts) ++ "}" ++ formatFullContextBrace c + +lookupValueFunction :: (Show c, CompileErrorM m, MergeableM m, + CompilerContext c m [String] a) => + ValueType -> FunctionCall c -> CompilerState a m (ScopedFunction c) +lookupValueFunction (ValueType WeakValue t) (FunctionCall c _ _ _) = + lift $ compileError $ "Use strong to convert " ++ show t ++ + " to optional first" ++ formatFullContextBrace c +lookupValueFunction (ValueType OptionalValue t) (FunctionCall c _ _ _) = + lift $ compileError $ "Use require to convert " ++ show t ++ + " to required first" ++ formatFullContextBrace c +lookupValueFunction (ValueType RequiredValue t) (FunctionCall c n _ _) = + csGetTypeFunction c (Just t) n + +compileExpressionStart :: (Show c, CompileErrorM m, MergeableM m, + CompilerContext c m [String] a) => + ExpressionStart c -> CompilerState a m (ExpressionType,ExprValue) +compileExpressionStart (NamedVariable (OutputValue c n)) = do + (VariableValue _ s t _) <- csGetVariable c n + csCheckVariableInit c n + scoped <- autoScope s + let lazy = s == CategoryScope + return (Positional [t],readStoredVariable lazy t (scoped ++ variableName n)) +compileExpressionStart (CategoryCall c t f@(FunctionCall _ n _ _)) = do + f' <- csGetCategoryFunction c (Just t) n + csRequiresTypes $ Set.fromList [t,sfType f'] + t' <- expandCategory t + compileFunctionCall (Just t') f' f +compileExpressionStart (TypeCall c t f@(FunctionCall _ n _ _)) = do + r <- csResolver + fa <- csAllFilters + lift $ validateGeneralInstance r fa (SingleType t) + f' <- csGetTypeFunction c (Just $ SingleType t) n + when (sfScope f' /= TypeScope) $ lift $ compileError $ "Function " ++ show n ++ + " cannot be used as a type function" ++ + formatFullContextBrace c + csRequiresTypes $ Set.unions $ map categoriesFromTypes [SingleType t] + csRequiresTypes $ Set.fromList [sfType f'] + t' <- expandGeneralInstance $ SingleType t + compileFunctionCall (Just t') f' f +compileExpressionStart (UnqualifiedCall c f@(FunctionCall _ n _ _)) = do + ctx <- get + f' <- lift $ collectOneOrErrorM [tryCategory ctx,tryNonCategory ctx] + csRequiresTypes $ Set.fromList [sfType f'] + compileFunctionCall Nothing f' f + where + tryCategory ctx = ccGetCategoryFunction ctx c Nothing n + tryNonCategory ctx = do + f' <- ccGetTypeFunction ctx c Nothing n + s <- ccCurrentScope ctx + when (sfScope f' > s) $ compileError $ + "Function " ++ show n ++ " is not in scope here" ++ formatFullContextBrace c + return f' +compileExpressionStart (BuiltinCall c f@(FunctionCall _ BuiltinPresent ps es)) = do + when (length (pValues ps) /= 0) $ + lift $ compileError $ "Expected 0 type parameters" ++ formatFullContextBrace c + when (length (pValues es) /= 1) $ + lift $ compileError $ "Expected 1 argument" ++ formatFullContextBrace c + es' <- sequence $ map compileExpression $ pValues es + when (length (pValues $ fst $ head es') /= 1) $ + lift $ compileError $ "Expected single return in argument" ++ formatFullContextBrace c + let (Positional [t0],e) = head es' + when (isWeakValue t0) $ + lift $ compileError $ "Weak values not allowed here" ++ formatFullContextBrace c + return $ (Positional [boolRequiredValue], + UnboxedPrimitive PrimBool $ valueBase ++ "::Present(" ++ useAsUnwrapped e ++ ")") +compileExpressionStart (BuiltinCall c f@(FunctionCall _ BuiltinReduce ps es)) = do + when (length (pValues ps) /= 2) $ + lift $ compileError $ "Expected 2 type parameters" ++ formatFullContextBrace c + when (length (pValues es) /= 1) $ + lift $ compileError $ "Expected 1 argument" ++ formatFullContextBrace c + es' <- sequence $ map compileExpression $ pValues es + when (length (pValues $ fst $ head es') /= 1) $ + lift $ compileError $ "Expected single return in argument" ++ formatFullContextBrace c + let (Positional [t0],e) = head es' + let (Positional [t1,t2]) = ps + r <- csResolver + fa <- csAllFilters + lift $ validateGeneralInstance r fa t1 + lift $ validateGeneralInstance r fa t2 + lift $ (checkValueTypeMatch r fa t0 (ValueType OptionalValue t1)) `reviseError` + ("In argument to reduce call at " ++ formatFullContext c) + -- TODO: If t1 -> t2 then just return e without a Reduce call. + t1' <- expandGeneralInstance t1 + t2' <- expandGeneralInstance t2 + csRequiresTypes $ categoriesFromTypes t1 + csRequiresTypes $ categoriesFromTypes t2 + return $ (Positional [ValueType OptionalValue t2], + UnwrappedSingle $ typeBase ++ "::Reduce(" ++ t1' ++ ", " ++ t2' ++ ", " ++ useAsUnwrapped e ++ ")") +-- TODO: Compile BuiltinCall like regular functions, for consistent validation. +compileExpressionStart (BuiltinCall c f@(FunctionCall _ BuiltinRequire ps es)) = do + when (length (pValues ps) /= 0) $ + lift $ compileError $ "Expected 0 type parameters" ++ formatFullContextBrace c + when (length (pValues es) /= 1) $ + lift $ compileError $ "Expected 1 argument" ++ formatFullContextBrace c + es' <- sequence $ map compileExpression $ pValues es + when (length (pValues $ fst $ head es') /= 1) $ + lift $ compileError $ "Expected single return in argument" ++ formatFullContextBrace c + let (Positional [t0],e) = head es' + when (isWeakValue t0) $ + lift $ compileError $ "Weak values not allowed here" ++ formatFullContextBrace c + return $ (Positional [ValueType RequiredValue (vtType t0)], + UnwrappedSingle $ valueBase ++ "::Require(" ++ useAsUnwrapped e ++ ")") +compileExpressionStart (BuiltinCall c f@(FunctionCall _ BuiltinStrong ps es)) = do + when (length (pValues ps) /= 0) $ + lift $ compileError $ "Expected 0 type parameters" ++ formatFullContextBrace c + when (length (pValues es) /= 1) $ + lift $ compileError $ "Expected 1 argument" ++ formatFullContextBrace c + es' <- sequence $ map compileExpression $ pValues es + when (length (pValues $ fst $ head es') /= 1) $ + lift $ compileError $ "Expected single return in argument" ++ formatFullContextBrace c + let (Positional [t0],e) = head es' + let t1 = Positional [ValueType OptionalValue (vtType t0)] + if isWeakValue t0 + -- Weak values are already unboxed. + then return (t1,UnwrappedSingle $ valueBase ++ "::Strong(" ++ useAsUnwrapped e ++ ")") + else return (t1,e) +compileExpressionStart (BuiltinCall c f@(FunctionCall _ BuiltinTypename ps es)) = do + when (length (pValues ps) /= 1) $ + lift $ compileError $ "Expected 1 type parameter" ++ formatFullContextBrace c + when (length (pValues es) /= 0) $ + lift $ compileError $ "Expected 0 arguments" ++ formatFullContextBrace c + let t = head $ pValues ps + r <- csResolver + fa <- csAllFilters + lift $ validateGeneralInstance r fa t + t' <- expandGeneralInstance t + csRequiresTypes $ Set.unions $ map categoriesFromTypes $ pValues ps + return $ (Positional [formattedRequiredValue], + valueAsWrapped $ UnboxedPrimitive PrimString $ typeBase ++ "::TypeName(" ++ t' ++ ")") +compileExpressionStart (ParensExpression c e) = compileExpression e +compileExpressionStart (InlineAssignment c n e) = do + (VariableValue c2 s t0 w) <- csGetVariable c n + when (not w) $ lift $ compileError $ "Cannot assign to read-only variable " ++ + show n ++ formatFullContextBrace c + (Positional [t],e') <- compileExpression e -- TODO: Get rid of the Positional matching here. + r <- csResolver + fa <- csAllFilters + lift $ (checkValueTypeMatch r fa t t0) `reviseError` + ("In assignment at " ++ formatFullContext c) + csUpdateAssigned n + scoped <- autoScope s + let lazy = s == CategoryScope + return (Positional [t0],readStoredVariable lazy t0 $ "(" ++ scoped ++ variableName n ++ + " = " ++ writeStoredVariable t0 e' ++ ")") + +compileFunctionCall :: (Show c, CompileErrorM m, MergeableM m, + CompilerContext c m [String] a) => + Maybe String -> ScopedFunction c -> FunctionCall c -> + CompilerState a m (ExpressionType,ExprValue) +compileFunctionCall e f (FunctionCall c _ ps es) = do + r <- csResolver + fa <- csAllFilters + f' <- lift $ parsedToFunctionType f `reviseError` + ("In function call at " ++ formatFullContext c) + f'' <- lift $ assignFunctionParams r fa ps f' `reviseError` + ("In function call at " ++ formatFullContext c) + es' <- sequence $ map compileExpression $ pValues es + (ts,es'') <- getValues es' + -- Called an extra time so arg count mismatches have reasonable errors. + lift $ processPairs (\_ _ -> return ()) (ftArgs f'') (Positional ts) `reviseError` + ("In function call at " ++ formatFullContext c) + lift $ processPairs (checkArg r fa) (ftArgs f'') (Positional $ zip [1..] ts) `reviseError` + ("In function call at " ++ formatFullContext c) + csRequiresTypes $ Set.unions $ map categoriesFromTypes $ pValues ps + csRequiresTypes (Set.fromList [sfType f]) + params <- expandParams2 ps + scoped <- autoScope (sfScope f) + call <- assemble e scoped (sfScope f) (functionName f) params es'' + return $ (ftReturns f'',OpaqueMulti call) + where + assemble Nothing _ ValueScope n ps es = + return $ callName (sfName f) ++ "(Var_self, " ++ ps ++ ", " ++ es ++ ")" + assemble Nothing scoped _ n ps es = + return $ scoped ++ callName (sfName f) ++ "(" ++ ps ++ ", " ++ es ++ ")" + assemble (Just e) _ ValueScope n ps es = + return $ valueBase ++ "::Call(" ++ e ++ ", " ++ functionName f ++ ", " ++ ps ++ ", " ++ es ++ ")" + assemble (Just e) _ _ n ps es = + return $ e ++ ".Call(" ++ functionName f ++ ", " ++ ps ++ ", " ++ es ++ ")" + -- TODO: Lots of duplication with assignments and initialization. + -- Single expression, but possibly multi-return. + getValues [(Positional ts,e)] = return (ts,useAsArgs e) + -- Multi-expression => must all be singles. + getValues rs = do + lift $ mergeAllM (map checkArity $ zip [1..] $ map fst rs) `reviseError` + ("In return at " ++ formatFullContext c) + return (map (head . pValues . fst) rs, "ArgTuple(" ++ intercalate ", " (map (useAsUnwrapped . snd) rs) ++ ")") + checkArity (_,Positional [_]) = return () + checkArity (i,Positional ts) = + compileError $ "Return position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1" + checkArg r fa t0 (i,t1) = do + checkValueTypeMatch r fa t1 t0 `reviseError` ("In argument " ++ show i) + +compileMainProcedure :: (Show c, CompileErrorM m, MergeableM m) => + CategoryMap c -> Expression c -> m (CompiledData [String]) +compileMainProcedure tm e = do + ctx <- getMainContext tm + runDataCompiler compiler ctx where + procedure = Procedure [] [IgnoreValues [] e] + compiler = do + ctx0 <- getCleanContext + compileProcedure ctx0 procedure >>= put + +autoScope :: (CompilerContext c m s a) => + SymbolScope -> CompilerState a m String +autoScope s = do + s1 <- csCurrentScope + return $ scoped s1 s + where + scoped ValueScope TypeScope = "parent." + scoped ValueScope CategoryScope = "parent.parent." + scoped TypeScope CategoryScope = "parent." + -- NOTE: Don't use this->; otherwise, self won't work properly. + scoped _ _ = "" + +categoriesFromTypes :: GeneralInstance -> Set.Set CategoryName +categoriesFromTypes = Set.fromList . getAll where + getAll (TypeMerge _ ps) = concat $ map getAll ps + getAll (SingleType (JustTypeInstance (TypeInstance t ps))) = t:(concat $ map getAll $ pValues ps) + getAll _ = [] + +expandParams :: (CompilerContext c m s a) => + Positional GeneralInstance -> CompilerState a m String +expandParams ps = do + ps' <- sequence $ map expandGeneralInstance $ pValues ps + return $ "T_get(" ++ intercalate "," (map ("&" ++) ps') ++ ")" + +expandParams2 :: (CompilerContext c m s a) => + Positional GeneralInstance -> CompilerState a m String +expandParams2 ps = do + ps' <- sequence $ map expandGeneralInstance $ pValues ps + return $ "ParamTuple(" ++ intercalate "," (map ("&" ++) ps') ++ ")" + +expandCategory :: (CompilerContext c m s a) => + CategoryName -> CompilerState a m String +expandCategory t = return $ categoryGetter t ++ "()" + +expandGeneralInstance :: (CompilerContext c m s a) => + GeneralInstance -> CompilerState a m String +expandGeneralInstance (TypeMerge MergeUnion []) = return $ allGetter ++ "()" +expandGeneralInstance (TypeMerge MergeIntersect []) = return $ anyGetter ++ "()" +expandGeneralInstance (TypeMerge m ps) = do + ps' <- sequence $ map expandGeneralInstance ps + return $ getter ++ "(L_get<" ++ typeBase ++ "*>(" ++ intercalate "," (map ("&" ++) ps') ++ "))" + where + getter + | m == MergeUnion = unionGetter + | m == MergeIntersect = intersectGetter +expandGeneralInstance (SingleType (JustTypeInstance (TypeInstance t ps))) = do + ps' <- sequence $ map expandGeneralInstance $ pValues ps + return $ typeGetter t ++ "(T_get(" ++ intercalate "," (map ("&" ++) ps') ++ "))" +expandGeneralInstance (SingleType (JustParamName p)) = do + s <- csGetParamScope p + scoped <- autoScope s + return $ scoped ++ paramName p + +doNamedReturn :: (CompilerContext c m [String] a) => CompilerState a m () +doNamedReturn = do + vars <- csPrimNamedReturns + sequence $ map (csWrite . (:[]) . assign) vars + doReturnCleanup + csWrite ["return returns;"] + where + assign (ReturnVariable i n t) = + "returns.At(" ++ show i ++ ") = " ++ useAsUnwrapped (readStoredVariable False t $ variableName n) ++ ";" + +doReturnCleanup :: (CompilerContext c m [String] a) => CompilerState a m () +doReturnCleanup = do + (CleanupSetup cs ss) <- csGetCleanup + if null ss + then return () + else do + sequence $ map (csInheritReturns . (:[])) cs + csWrite ss diff --git a/src/Config/LoadConfig.hs b/src/Config/LoadConfig.hs new file mode 100644 --- /dev/null +++ b/src/Config/LoadConfig.hs @@ -0,0 +1,155 @@ +{- ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Config.LoadConfig ( + Backend(..), + LocalConfig(..), + Resolver(..), + localConfigPath, + loadConfig, +) where + +import Config.Paths +import Config.Programs + +import Control.Monad (when) +import GHC.IO.Handle +import Data.List (intercalate,isSuffixOf) +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.Posix.Process (ProcessStatus(..),executeFile,forkProcess,getProcessStatus) +import System.Posix.Temp (mkstemps) + +import Paths_zeolite_lang (getDataFileName) + + +loadConfig :: IO (Backend,Resolver) +loadConfig = do + f <- localConfigPath + isFile <- doesFileExist f + when (not isFile) $ do + hPutStrLn stderr "Zeolite has not been configured. Please run zeolite-setup." + exitFailure + c <- readFile f + lc <- check $ (reads c :: [(LocalConfig,String)]) + return (lcBackend lc,lcResolver lc) where + check [(cm,"")] = return cm + check [(cm,"\n")] = return cm + check _ = do + hPutStrLn stderr "Zeolite configuration is corrupt. Please rerun zeolite-setup." + exitFailure + +data Backend = + UnixBackend { + ucCxxBinary :: String, + ucCxxOptions :: [String], + ucArBinary :: String + } + deriving (Read,Show) + +data Resolver = SimpleResolver deriving (Read,Show) + +data LocalConfig = + LocalConfig { + lcBackend :: Backend, + lcResolver :: Resolver + } + deriving (Read,Show) + +localConfigFilename = "local-config.txt" + +localConfigPath :: IO FilePath +localConfigPath = getDataFileName localConfigFilename >>= canonicalizePath + +instance CompilerBackend Backend where + runCxxCommand (UnixBackend cb co ab) (CompileToObject s p nm ns ps e) = do + objName <- canonicalizePath $ p (takeFileName $ dropExtension s ++ ".o") + executeProcess cb $ co ++ otherOptions ++ ["-c", s, "-o", objName] + if e + then do + -- Extra files are put into .a since they will be unconditionally + -- included. This prevents unwanted symbol dependencies. + arName <- canonicalizePath $ p (takeFileName $ dropExtension s ++ ".a") + executeProcess ab ["-q",arName,objName] + return arName + else return objName where + otherOptions = map (("-I" ++) . normalise) ps ++ nsFlag + nsFlag + | null ns = [] + | otherwise = ["-D" ++ nm ++ "=" ++ ns] + runCxxCommand (UnixBackend cb co ab) (CompileToBinary m ss o ps) = do + let arFiles = filter (isSuffixOf ".a") ss + let otherFiles = filter (not . isSuffixOf ".a") ss + executeProcess cb $ co ++ otherOptions ++ m:otherFiles ++ arFiles ++ ["-o", o] + return o where + otherOptions = map ("-I" ++) $ map normalise ps + runTestCommand _ (TestCommand b p) = do + (outF,outH) <- mkstemps "/tmp/ztest_" ".txt" + (errF,errH) <- mkstemps "/tmp/ztest_" ".txt" + pid <- forkProcess (execWithCapture outH errH) + hClose outH + hClose errH + status <- getProcessStatus True True pid + out <- readFile outF + err <- readFile errF + let success = case status of + Just (Exited ExitSuccess) -> True + _ -> False + return $ TestCommandResult success (lines out) (lines err) where + execWithCapture h1 h2 = do + when (not $ null p) $ setCurrentDirectory p + hDuplicateTo h1 stdout + hDuplicateTo h2 stderr + executeFile b True [] Nothing + +executeProcess :: String -> [String] -> IO () +executeProcess c os = do + hPutStrLn stderr $ "Executing: " ++ intercalate " " (c:os) + pid <- forkProcess $ executeFile c True os Nothing + status <- getProcessStatus True True pid + case status of + Just (Exited ExitSuccess) -> return () + _ -> exitFailure + +instance PathResolver Resolver where + resolveModule SimpleResolver p m = do + m' <- getDataFileName m + firstExisting m [pm,m'] + resolveBaseModule r = do + let m = "base" + m' <- getDataFileName m + firstExisting m [m'] + resolveBinary SimpleResolver = canonicalizePath + isBaseModule r@SimpleResolver f = do + b <- resolveBaseModule r + return (f == b) + +firstExisting :: FilePath -> [FilePath] -> IO FilePath +firstExisting n [] = do + -- TODO: Allow error recovery here. + hPutStrLn stderr $ "Could not find path " ++ n + exitFailure +firstExisting n (p:ps) = do + isDir <- doesDirectoryExist p + if isDir + then canonicalizePath p + else firstExisting n ps diff --git a/src/Config/Paths.hs b/src/Config/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Config/Paths.hs @@ -0,0 +1,32 @@ +{- ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Config.Paths ( + PathResolver(..), +) where + +import System.FilePath + + +class PathResolver r where + resolveModule :: r -> FilePath -> FilePath -> IO FilePath + resolveBaseModule :: r -> IO FilePath + resolveBinary :: r -> FilePath -> IO FilePath + isBaseModule :: r -> FilePath -> IO Bool diff --git a/src/Config/Programs.hs b/src/Config/Programs.hs new file mode 100644 --- /dev/null +++ b/src/Config/Programs.hs @@ -0,0 +1,63 @@ +{- ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Config.Programs ( + CompilerBackend(..), + CxxCommand(..), + TestCommand(..), + TestCommandResult(..), +) where + + +class CompilerBackend b where + runCxxCommand :: b -> CxxCommand -> IO String + runTestCommand :: b -> TestCommand -> IO TestCommandResult + +data CxxCommand = + CompileToObject { + ctoSource :: String, + ctoPath :: String, + ctoNamespaceMacro :: String, + ctoNamespace :: String, + ctoPaths :: [String], + ctoExtra :: Bool + } | + CompileToBinary { + ctbMain :: String, + ctbSources :: [String], + ctbOutput :: String, + ctoPaths :: [String] + } + deriving (Show) + +data TestCommand = + TestCommand { + tcBinary :: String, + tcPath :: String + } + deriving (Show) + +data TestCommandResult = + TestCommandResult { + tcrSuccess :: Bool, + tcrOutput :: [String], + tcrError :: [String] + } + deriving (Show) diff --git a/src/Parser/Common.hs b/src/Parser/Common.hs new file mode 100644 --- /dev/null +++ b/src/Parser/Common.hs @@ -0,0 +1,350 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Parser.Common ( + ParseFromSource(..), + anyComment, + assignOperator, + blockComment, + builtinValues, + categorySymbolGet, + endOfDoc, + escapeStart, + infixFuncEnd, + infixFuncStart, + keyword, + kwAll, + kwAllows, + kwAny, + kwBreak, + kwCategory, + kwCleanup, + kwConcrete, + kwContinue, + kwDefine, + kwDefines, + kwElif, + kwElse, + kwEmpty, + kwFail, + kwFalse, + kwIf, + kwIn, + kwIgnore, + kwInterface, + kwOptional, + kwPresent, + kwReduce, + kwRefines, + kwRequire, + kwRequires, + kwReturn, + kwSelf, + kwScoped, + kwStrong, + kwTestcase, + kwTrue, + kwType, + kwTypename, + kwTypes, + kwUpdate, + kwValue, + kwWeak, + kwWhile, + labeled, + lineComment, + merge2, + merge3, + noKeywords, + notAllowed, + nullParse, + operator, + optionalSpace, + parseBin, + parseDec, + parseHex, + parseOct, + parseSubOne, + put12, + put13, + put22, + put23, + put33, + regexChar, + requiredSpace, + sepAfter, + sepAfter1, + stringChar, + statementEnd, + statementStart, + typeSymbolGet, + valueSymbolGet, +) where + +import Data.Char +import Data.Monoid ((<>)) +import Text.Parsec +import Text.Parsec.String +import qualified Data.Set as Set + + +class ParseFromSource a where + -- Should never prune whitespace/comments from front, but always from back. + sourceParser :: Parser a + +labeled = flip label + +escapeStart = sepAfter (string "\\" >> return ()) +statementStart = sepAfter (string "~" >> return ()) +statementEnd = sepAfter (string "" >> return ()) +valueSymbolGet = sepAfter (string "." >> return ()) +categorySymbolGet = sepAfter (string "$$" >> return ()) +typeSymbolGet = sepAfter (string "$" >> notFollowedBy (string "$")) +assignOperator = operator "<-" +infixFuncStart = sepAfter (string "`" >> return ()) +infixFuncEnd = sepAfter (string "`" >> return ()) + +-- TODO: Maybe this should not use strings. +builtinValues :: Parser String +builtinValues = foldr (<|>) (fail "empty") $ map try [ + kwSelf >> return "self" + ] + +kwAll = keyword "all" +kwAllows = keyword "allows" +kwAny = keyword "any" +kwBreak = keyword "break" +kwCategory = keyword "@category" +kwCleanup = keyword "cleanup" +kwConcrete = keyword "concrete" +kwContinue = keyword "continue" +kwDefine = keyword "define" +kwDefines = keyword "defines" +kwElif = keyword "elif" +kwElse = keyword "else" +kwEmpty = keyword "empty" +kwFail = keyword "fail" +kwFalse = keyword "false" +kwIf = keyword "if" +kwIn = keyword "in" +kwIgnore = keyword "_" +kwInterface = keyword "interface" +kwOptional = keyword "optional" +kwPresent = keyword "present" +kwReduce = keyword "reduce" +kwRefines = keyword "refines" +kwRequire = keyword "require" +kwRequires = keyword "requires" +kwReturn = keyword "return" +kwSelf = keyword "self" +kwScoped = keyword "scoped" +kwStrong = keyword "strong" +kwTestcase = keyword "testcase" +kwTrue = keyword "true" +kwType = keyword "@type" +kwTypename = keyword "typename" +kwTypes = keyword "types" +kwUpdate = keyword "update" +kwValue = keyword "@value" +kwWeak = keyword "weak" +kwWhile = keyword "while" + +operatorSymbol = labeled "operator symbol" $ satisfy (`Set.member` Set.fromList "+-*/%=!<>&|") + +isKeyword :: Parser () +isKeyword = foldr (<|>) nullParse $ map try [ + kwAll, + kwAllows, + kwAny, + kwBreak, + kwCategory, + kwCleanup, + kwConcrete, + kwContinue, + kwDefine, + kwDefines, + kwElif, + kwElse, + kwEmpty, + kwFail, + kwFalse, + kwIf, + kwIn, + kwIgnore, + kwInterface, + kwOptional, + kwPresent, + kwReduce, + kwRefines, + kwRequire, + kwRequires, + kwReturn, + kwSelf, + kwScoped, + kwStrong, + kwTestcase, + kwTrue, + kwType, + kwTypename, + kwTypes, + kwUpdate, + kwValue, + kwWeak, + kwWhile + ] + +nullParse :: Parser () +nullParse = return () + +lineComment :: Parser String +lineComment = between (string "//") + endOfLine + (many $ satisfy (/= '\n')) + +blockComment :: Parser String +blockComment = between (string "/*") + (string "*/") + (many $ notFollowedBy (string "*/") >> anyChar) + +anyComment :: Parser String +anyComment = try blockComment <|> try lineComment + +optionalSpace :: Parser () +optionalSpace = labeled "" $ many (anyComment <|> many1 space) >> nullParse + +requiredSpace :: Parser () +requiredSpace = labeled "break" $ eof <|> (many1 (anyComment <|> many1 space) >> nullParse) + +sepAfter :: Parser a -> Parser a +sepAfter = between nullParse optionalSpace + +sepAfter1 :: Parser a -> Parser a +sepAfter1 = between nullParse requiredSpace + +keyword :: String -> Parser () +keyword s = labeled s $ sepAfter $ string s >> (labeled "" $ notFollowedBy (many alphaNum)) + +noKeywords :: Parser () +noKeywords = notFollowedBy isKeyword + +endOfDoc :: Parser () +endOfDoc = labeled "" $ optionalSpace >> eof + +notAllowed :: Parser a -> String -> Parser () +-- Based on implementation of notFollowedBy. +notAllowed p s = (try p >> fail s) <|> return () + +operator :: String -> Parser String +operator o = labeled o $ do + string o + notFollowedBy operatorSymbol + optionalSpace + return o + +stringChar :: Parser Char +stringChar = escaped <|> notEscaped where + escaped = labeled "escaped char sequence" $ do + char '\\' + octChar <|> otherEscape where + otherEscape = do + v <- anyChar + case v of + '\'' -> return '\'' + '"' -> return '"' + '?' -> return '?' + '\\' -> return '\\' + 'a' -> return $ chr 7 + 'b' -> return $ chr 8 + 'f' -> return $ chr 12 + 'n' -> return $ chr 10 + 'r' -> return $ chr 13 + 't' -> return $ chr 9 + 'v' -> return $ chr 11 + 'x' -> hexChar + _ -> fail (show v) + octChar = labeled "3 octal chars" $ do + o1 <- octDigit >>= return . digitVal + o2 <- octDigit >>= return . digitVal + o3 <- octDigit >>= return . digitVal + return $ chr $ 8*8*o1 + 8*o2 + o3 + hexChar = labeled "2 hex chars" $ do + h1 <- hexDigit >>= return . digitVal + h2 <- hexDigit >>= return . digitVal + return $ chr $ 16*h1 + h2 + notEscaped = noneOf "\"" + +digitVal :: Char -> Int +digitVal c + | c >= '0' && c <= '9' = ord(c) - ord('0') + | c >= 'A' && c <= 'F' = 10 + ord(c) - ord('A') + | c >= 'a' && c <= 'f' = 10 + ord(c) - ord('a') + +parseDec :: Parser Integer +parseDec = fmap snd $ parseIntCommon 10 digit + +parseHex :: Parser Integer +parseHex = fmap snd $ parseIntCommon 16 hexDigit + +parseOct :: Parser Integer +parseOct = fmap snd $ parseIntCommon 8 octDigit + +parseBin :: Parser Integer +parseBin = fmap snd $ parseIntCommon 2 (oneOf "01") + +parseSubOne :: Parser (Integer,Integer) +parseSubOne = parseIntCommon 10 digit + +parseIntCommon :: Integer -> Parser Char -> Parser (Integer,Integer) +parseIntCommon b p = do + ds <- many1 p + return $ foldl (\(n,x) y -> (n+1,b*x + (fromIntegral $ digitVal y :: Integer))) (0,0) ds + +regexChar :: Parser String +regexChar = escaped <|> notEscaped where + escaped = do + char '\\' + v <- anyChar + case v of + '"' -> return "\"" + _ -> return ['\\',v] + notEscaped = fmap (:[]) $ noneOf "\"" + +put12 :: Monad m => m a -> m ([a],[b]) +put12 = fmap put where put x = ([x],[]) + +put22 :: Monad m => m b -> m ([a],[b]) +put22 = fmap put where put x = ([],[x]) + +merge2 :: (Foldable f, Monoid a, Monoid b) => f (a,b) -> (a,b) +merge2 = foldr merge (mempty,mempty) where + merge (xs1,ys1) (xs2,ys2) = (xs1<>xs2,ys1<>ys2) + +put13 :: Monad m => m a -> m ([a],[b],[c]) +put13 = fmap put where put x = ([x],[],[]) + +put23 :: Monad m => m b -> m ([a],[b],[c]) +put23 = fmap put where put x = ([],[x],[]) + +put33 :: Monad m => m c -> m ([a],[b],[c]) +put33 = fmap put where put x = ([],[],[x]) + +merge3 :: (Foldable f, Monoid a, Monoid b, Monoid c) => f (a,b,c) -> (a,b,c) +merge3 = foldr merge (mempty,mempty,mempty) where + merge (xs1,ys1,zs1) (xs2,ys2,zs2) = (xs1<>xs2,ys1<>ys2,zs1<>zs2) diff --git a/src/Parser/DefinedCategory.hs b/src/Parser/DefinedCategory.hs new file mode 100644 --- /dev/null +++ b/src/Parser/DefinedCategory.hs @@ -0,0 +1,127 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} + +module Parser.DefinedCategory ( + parseAnySource, +) where + +import Control.Monad (when) +import Text.Parsec +import Text.Parsec.String + +import Parser.Common +import Parser.Procedure +import Parser.TypeCategory +import Parser.TypeInstance +import Types.DefinedCategory +import Types.Procedure +import Types.TypeCategory +import Types.TypeInstance +import Types.Variance + + +instance ParseFromSource (DefinedCategory SourcePos) where + sourceParser = labeled "defined concrete category" $ do + c <- getPosition + kwDefine + n <- sourceParser + sepAfter (string "{") + (ds,rs) <- parseRefinesDefines + (pi,fi) <- parseInternalParams <|> return ([],[]) + (ms,ps,fs) <- parseMemberProcedureFunction n + sepAfter (string "}") + return $ DefinedCategory [c] n pi ds rs fi ms ps fs + where + parseRefinesDefines = fmap merge2 $ sepBy refineOrDefine optionalSpace + refineOrDefine = labeled "refine or define" $ put12 singleRefine <|> put22 singleDefine + parseInternalParams = labeled "internal params" $ do + try kwTypes + pi <- between (sepAfter $ string "<") + (sepAfter $ string ">") + (sepBy singleParam (sepAfter $ string ",")) + fi <- parseInternalFilters + return (pi,fi) + parseInternalFilters = do + try $ sepAfter (string "{") + fi <- parseFilters + sepAfter (string "}") + return fi + singleParam = labeled "param declaration" $ do + c <- getPosition + n <- sourceParser + return $ ValueParam [c] n Invariant + +instance ParseFromSource (DefinedMember SourcePos) where + sourceParser = labeled "defined member" $ do + c <- getPosition + (s,t) <- try parseType + n <- sourceParser + e <- if s == ValueScope + then return Nothing + else parseInit + return $ DefinedMember [c] s t n e + where + parseInit = labeled "member initializer" $ do + assignOperator + e <- sourceParser + return $ Just e + parseType = do + s <- parseScope + t <- sourceParser + return (s,t) + +parseMemberProcedureFunction :: + CategoryName -> + Parser ([DefinedMember SourcePos],[ExecutableProcedure SourcePos],[ScopedFunction SourcePos]) +parseMemberProcedureFunction n = parsed >>= return . foldr merge empty where + empty = ([],[],[]) + merge (ms1,ps1,fs1) (ms2,ps2,fs2) = (ms1++ms2,ps1++ps2,fs1++fs2) + parsed = sepBy anyType optionalSpace + anyType = labeled "" $ catchUnscopedType <|> singleMember <|> singleProcedure <|> singleFunction + singleMember = labeled "member" $ do + m <- sourceParser + return ([m],[],[]) + singleProcedure = labeled "procedure" $ do + p <- sourceParser + return ([],[p],[]) + singleFunction = labeled "function" $ do + f <- try $ parseScopedFunction parseScope (return n) + p <- labeled ("definition of function " ++ show (sfName f)) $ sourceParser + when (sfName f /= epName p) $ + fail $ "expecting definition of function " ++ show (sfName f) ++ + " but got definition of " ++ show (epName p) + return ([],[p],[f]) + catchUnscopedType = do + t <- try sourceParser :: Parser ValueType + fail $ "members must have an explicit @value or @category scope" + +parseAnySource :: Parser ([AnyCategory SourcePos],[DefinedCategory SourcePos]) +parseAnySource = parsed >>= return . foldr merge empty where + empty = ([],[]) + merge (cs1,ds1) (cs2,ds2) = (cs1++cs2,ds1++ds2) + parsed = sepBy anyType optionalSpace + anyType = singleCategory <|> singleDefine + singleCategory = do + c <- sourceParser + return ([c],[]) + singleDefine = do + d <- sourceParser + return ([],[d]) diff --git a/src/Parser/IntegrationTest.hs b/src/Parser/IntegrationTest.hs new file mode 100644 --- /dev/null +++ b/src/Parser/IntegrationTest.hs @@ -0,0 +1,96 @@ +{- ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} + +module Parser.IntegrationTest ( +) where + +import Text.Parsec +import Text.Parsec.String + +import Parser.Common +import Parser.DefinedCategory +import Parser.Procedure +import Parser.TypeCategory +import Types.IntegrationTest + + +instance ParseFromSource (IntegrationTestHeader SourcePos) where + sourceParser = labeled "testcase" $ do + c <- getPosition + sepAfter kwTestcase + string "\"" + name <- manyTill stringChar (string "\"") + optionalSpace + sepAfter $ string "{" + result <- resultError <|> resultCrash <|> resultSuccess + sepAfter $ string "}" + return $ IntegrationTestHeader [c] name result where + resultError = labeled "error expectation" $ do + c <- getPosition + sepAfter (keyword "error") + (req,exc) <- requireOrExclude + return $ ExpectCompileError [c] req exc + resultCrash = labeled "crash expectation" $ do + c <- getPosition + sepAfter (keyword "crash") + e <- labeled "test expression" sourceParser + (req,exc) <- requireOrExclude + return $ ExpectRuntimeError [c] e req exc + resultSuccess = labeled "success expectation" $ do + c <- getPosition + sepAfter (keyword "success") + e <- labeled "test expression" sourceParser + (req,exc) <- requireOrExclude + return $ ExpectRuntimeSuccess [c] e req exc + requireOrExclude = parsed >>= return . foldr merge empty where + empty = ([],[]) + merge (cs1,ds1) (cs2,ds2) = (cs1++cs2,ds1++ds2) + parsed = sepBy anyType optionalSpace + anyType = require <|> exclude where + require = do + sepAfter (keyword "require") + s <- outputScope + string "\"" + r <- fmap concat $ manyTill regexChar (string "\"") + optionalSpace + return ([OutputPattern s r],[]) + exclude = do + sepAfter (keyword "exclude") + s <- outputScope + string "\"" + e <- fmap concat $ manyTill regexChar (string "\"") + optionalSpace + return ([],[OutputPattern s e]) + outputScope = try anyScope <|> + try compilerScope <|> + try stderrScope <|> + try stdoutScope <|> + return OutputAny + anyScope = sepAfter (keyword "any") >> return OutputAny + compilerScope = sepAfter (keyword "compiler") >> return OutputCompiler + stderrScope = sepAfter (keyword "stderr") >> return OutputStderr + stdoutScope = sepAfter (keyword "stdout") >> return OutputStdout + +instance ParseFromSource (IntegrationTest SourcePos) where + sourceParser = labeled "integration test" $ do + h <- sourceParser + (cs,ds) <- parseAnySource + return $ IntegrationTest h cs ds diff --git a/src/Parser/Procedure.hs b/src/Parser/Procedure.hs new file mode 100644 --- /dev/null +++ b/src/Parser/Procedure.hs @@ -0,0 +1,537 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} + +module Parser.Procedure ( +) where + +import Text.Parsec +import Text.Parsec.String +import qualified Data.Set as Set + +import Parser.Common +import Parser.TypeCategory +import Parser.TypeInstance +import Types.Positional +import Types.Procedure +import Types.TypeCategory +import Types.TypeInstance + + +instance ParseFromSource (ExecutableProcedure SourcePos) where + sourceParser = labeled "executable procedure" $ do + c <- getPosition + n <- try sourceParser + as <- sourceParser + rs <- sourceParser + sepAfter (string "{") + pp <- sourceParser + c2 <- getPosition + sepAfter (string "}") + return $ ExecutableProcedure [c] [c2] n as rs pp + +instance ParseFromSource (ArgValues SourcePos) where + sourceParser = labeled "procedure arguments" $ do + c <- getPosition + as <- between (sepAfter $ string "(") + (sepAfter $ string ")") + (sepBy sourceParser (sepAfter $ string ",")) + return $ ArgValues [c] (Positional as) + +instance ParseFromSource (ReturnValues SourcePos) where + sourceParser = labeled "procedure returns" $ namedReturns <|> unnamedReturns where + namedReturns = do + c <- getPosition + rs <- between (sepAfter $ string "(") + (sepAfter $ string ")") + (sepBy sourceParser (sepAfter $ string ",")) + return $ NamedReturns [c] (Positional rs) + unnamedReturns = do + c <- getPosition + notFollowedBy (string "(") + return $ UnnamedReturns [c] + +instance ParseFromSource VariableName where + sourceParser = labeled "variable name" $ do + noKeywords + b <- lower + e <- sepAfter $ many alphaNum + return $ VariableName (b:e) + +instance ParseFromSource (InputValue SourcePos) where + sourceParser = labeled "input variable" $ variable <|> discard where + variable = do + c <- getPosition + v <- sourceParser + return $ InputValue [c] v + discard = do + c <- getPosition + sepAfter $ string "_" + return $ DiscardInput [c] + +instance ParseFromSource (OutputValue SourcePos) where + sourceParser = labeled "output variable" $ do + c <- getPosition + v <- sourceParser + return $ OutputValue [c] v + +instance ParseFromSource (Procedure SourcePos) where + sourceParser = labeled "procedure" $ do + c <- getPosition + rs <- sepBy sourceParser optionalSpace + return $ Procedure [c] rs + +instance ParseFromSource (Statement SourcePos) where + sourceParser = parseReturn <|> + parseBreak <|> + parseContinue <|> + parseFailCall <|> + parseVoid <|> + parseAssign <|> + parseIgnore where + parseAssign = labeled "statement" $ do + c <- getPosition + as <- multiDest <|> singleDest + e <- sourceParser + statementEnd + return $ Assignment [c] (Positional as) e + parseBreak = labeled "break" $ do + c <- getPosition + try kwBreak + return $ LoopBreak [c] + parseContinue = labeled "continue" $ do + c <- getPosition + try kwContinue + return $ LoopContinue [c] + parseFailCall = do + c <- getPosition + try kwFail + e <- between (sepAfter $ string "(") (sepAfter $ string ")") sourceParser + return $ FailCall [c] e + multiDest = do + as <- try $ between (sepAfter $ string "{") + (sepAfter $ string "}") + (sepBy sourceParser (sepAfter $ string ",")) + assignOperator + return as + singleDest = do + a <- try sourceParser + assignOperator + return [a] + parseIgnore = do + c <- getPosition + statementStart + e <- sourceParser + statementEnd + return $ IgnoreValues [c] e + parseReturn = labeled "return" $ do + c <- getPosition + try kwReturn + multiReturn c <|> singleReturn c <|> emptyReturn c + multiReturn :: SourcePos -> Parser (Statement SourcePos) + multiReturn c = do + rs <- between (sepAfter $ string "{") + (sepAfter $ string "}") + (sepBy sourceParser (sepAfter $ string ",")) + statementEnd + return $ ExplicitReturn [c] (Positional rs) + singleReturn :: SourcePos -> Parser (Statement SourcePos) + singleReturn c = do + r <- sourceParser + statementEnd + return $ ExplicitReturn [c] (Positional [r]) + emptyReturn :: SourcePos -> Parser (Statement SourcePos) + emptyReturn c = do + kwIgnore + statementEnd + return $ EmptyReturn [c] + parseVoid = do + c <- getPosition + e <- sourceParser + return $ NoValueExpression [c] e + +instance ParseFromSource (Assignable SourcePos) where + sourceParser = existing <|> create where + create = labeled "variable creation" $ do + t <- sourceParser + strayFuncCall <|> return () + c <- getPosition + n <- sourceParser + return $ CreateVariable [c] t n + existing = labeled "variable name" $ do + n <- sourceParser + strayFuncCall <|> return () + return $ ExistingVariable n + strayFuncCall = do + valueSymbolGet <|> try typeSymbolGet <|> categorySymbolGet + fail "function returns must be explicitly handled" + +instance ParseFromSource (VoidExpression SourcePos) where + sourceParser = conditional <|> loop <|> scoped where + conditional = do + e <- sourceParser + return $ Conditional e + loop = do + e <- sourceParser + return $ Loop e + scoped = do + e <- sourceParser + return $ WithScope e + +instance ParseFromSource (IfElifElse SourcePos) where + sourceParser = labeled "if-elif-else" $ do + c <- getPosition + try kwIf >> parseIf c + where + parseIf c = do + i <- between (sepAfter $ string "(") (sepAfter $ string ")") sourceParser + p <- between (sepAfter $ string "{") (sepAfter $ string "}") sourceParser + next <- parseElif <|> parseElse <|> return TerminateConditional + return $ IfStatement [c] i p next + parseElif = do + c <- getPosition + try kwElif >> parseIf c + parseElse = do + c <- getPosition + try kwElse + p <- between (sepAfter $ string "{") (sepAfter $ string "}") sourceParser + return $ ElseStatement [c] p + +instance ParseFromSource (WhileLoop SourcePos) where + sourceParser = labeled "while" $ do + c <- getPosition + try kwWhile + i <- between (sepAfter $ string "(") (sepAfter $ string ")") sourceParser + p <- between (sepAfter $ string "{") (sepAfter $ string "}") sourceParser + u <- fmap Just parseUpdate <|> return Nothing + return $ WhileLoop [c] i p u + where + parseUpdate = do + try kwUpdate + between (sepAfter $ string "{") (sepAfter $ string "}") sourceParser + +instance ParseFromSource (ScopedBlock SourcePos) where + sourceParser = scoped <|> justCleanup where + scoped = labeled "scoped" $ do + c <- getPosition + try kwScoped + p <- between (sepAfter $ string "{") (sepAfter $ string "}") sourceParser + cl <- fmap Just parseCleanup <|> return Nothing + kwIn + s <- sourceParser <|> unconditional + return $ ScopedBlock [c] p cl s + justCleanup = do + c <- getPosition + cl <- parseCleanup + kwIn + s <- sourceParser <|> unconditional + return $ ScopedBlock [c] (Procedure [] []) (Just cl) s + parseCleanup = do + try kwCleanup + between (sepAfter $ string "{") (sepAfter $ string "}") sourceParser + unconditional = do + c <- getPosition + p <- between (sepAfter $ string "{") (sepAfter $ string "}") sourceParser + return $ NoValueExpression [c] (Unconditional p) + +unaryOperator :: Parser (Operator c) +unaryOperator = op >>= return . NamedOperator where + op = labeled "unary operator" $ foldr (<|>) (fail "empty") $ map (try . operator) [ + "!", "-" + ] + +infixOperator :: Parser (Operator c) +infixOperator = op >>= return . NamedOperator where + op = labeled "binary operator" $ foldr (<|>) (fail "empty") $ map (try . operator) [ + "+","-","*","/","%","==","!=","<","<=",">",">=","&&","||" + ] + +infixBefore :: Operator c -> Operator c -> Bool +infixBefore o1 o2 = (infixOrder o1) <= (infixOrder o2) where + infixOrder (NamedOperator o) + -- TODO: Don't hard-code this. + | o `Set.member` Set.fromList ["*","/","%"] = 1 + | o `Set.member` Set.fromList ["+","-"] = 2 + | o `Set.member` Set.fromList ["==","!=","<","<=",">",">="] = 4 + | o `Set.member` Set.fromList ["&&","||"] = 5 + infixOrder _ = 3 + +functionOperator :: Parser (Operator SourcePos) +functionOperator = do + c <- getPosition + infixFuncStart + q <- sourceParser + infixFuncEnd + return $ FunctionOperator [c] q + +instance ParseFromSource (Expression SourcePos) where + sourceParser = do + e <- notInfix + asInfix [e] [] <|> return e + where + notInfix = literal <|> unary <|> expression <|> initalize + asInfix es os = do + c <- getPosition + o <- infixOperator <|> functionOperator + e2 <- notInfix + let es' = es ++ [e2] + let os' = os ++ [([c],o)] + asInfix es' os' <|> return (infixToTree [] es' os') + infixToTree [(e1,c1,o1)] [e2] [] = InfixExpression c1 e1 o1 e2 + infixToTree [] (e1:es) ((c1,o1):os) = infixToTree [(e1,c1,o1)] es os + infixToTree ((e1,c1,o1):ss) [e2] [] = let e2' = InfixExpression c1 e1 o1 e2 in + infixToTree ss [e2'] [] + infixToTree ((e1,c1,o1):ss) (e2:es) ((c2,o2):os) + | o1 `infixBefore` o2 = let e1' = InfixExpression c1 e1 o1 e2 in + infixToTree ss (e1':es) ((c2,o2):os) + | otherwise = infixToTree ((e2,c2,o2):(e1,c1,o1):ss) es os + literal = do + l <- sourceParser + return $ Literal l + unary = do + c <- getPosition + o <- unaryOperator <|> functionOperator + e <- notInfix + return $ UnaryExpression [c] o e + expression = labeled "expression" $ do + c <- getPosition + s <- try sourceParser + vs <- many sourceParser + return $ Expression [c] s vs + initalize = do + c <- getPosition + t <- try sourceParser :: Parser TypeInstance + sepAfter (string "{") + withParams c t <|> withoutParams c t + withParams c t = do + try kwTypes + ps <- between (sepAfter $ string "<") + (sepAfter $ string ">") + (sepBy sourceParser (sepAfter $ string ",")) + as <- (sepAfter (string ",") >> sepBy sourceParser (sepAfter $ string ",")) <|> return [] + sepAfter (string "}") + return $ InitializeValue [c] t (Positional ps) (Positional as) + withoutParams c t = do + as <- sepBy sourceParser (sepAfter $ string ",") + sepAfter (string "}") + return $ InitializeValue [c] t (Positional []) (Positional as) + +instance ParseFromSource (FunctionQualifier SourcePos) where + -- TODO: This is probably better done iteratively. + sourceParser = try valueFunc <|> try categoryFunc <|> try typeFunc where + categoryFunc = do + c <- getPosition + q <- sourceParser + categorySymbolGet + return $ CategoryFunction [c] q + typeFunc = do + c <- getPosition + q <- sourceParser + typeSymbolGet + return $ TypeFunction [c] q + valueFunc = do + c <- getPosition + q <- sourceParser + valueSymbolGet + return $ ValueFunction [c] q + +instance ParseFromSource (FunctionSpec SourcePos) where + sourceParser = try qualified <|> unqualified where + qualified = do + c <- getPosition + q <- sourceParser + n <- sourceParser + ps <- try $ between (sepAfter $ string "<") + (sepAfter $ string ">") + (sepBy sourceParser (sepAfter $ string ",")) <|> return [] + return $ FunctionSpec [c] q n (Positional ps) + unqualified = do + c <- getPosition + n <- sourceParser + ps <- try $ between (sepAfter $ string "<") + (sepAfter $ string ">") + (sepBy sourceParser (sepAfter $ string ",")) <|> return [] + return $ FunctionSpec [c] UnqualifiedFunction n (Positional ps) + +parseFunctionCall :: SourcePos -> FunctionName -> Parser (FunctionCall SourcePos) +parseFunctionCall c n = do + -- NOTE: try is needed here so that < operators work when the left side is + -- just a variable name, e.g., x < y. + ps <- try $ between (sepAfter $ string "<") + (sepAfter $ string ">") + (sepBy sourceParser (sepAfter $ string ",")) <|> return [] + es <- between (sepAfter $ string "(") + (sepAfter $ string ")") + (sepBy sourceParser (sepAfter $ string ",")) + return $ FunctionCall [c] n (Positional ps) (Positional es) + +builtinFunction :: Parser FunctionName +builtinFunction = foldr (<|>) (fail "empty") $ map try [ + kwPresent >> return BuiltinPresent, + kwReduce >> return BuiltinReduce, + kwRequire >> return BuiltinRequire, + kwStrong >> return BuiltinStrong, + kwTypename >> return BuiltinTypename + ] + +instance ParseFromSource (ExpressionStart SourcePos) where + sourceParser = labeled "expression start" $ + parens <|> + variableOrUnqualified <|> + builtinCall <|> + builtinValue <|> + try typeOrCategoryCall <|> + typeCall where + parens = do + c <- getPosition + sepAfter (string "(") + e <- try (assign c) <|> expr c + sepAfter (string ")") + return e + assign :: SourcePos -> Parser (ExpressionStart SourcePos) + assign c = do + n <- sourceParser + assignOperator + e <- sourceParser + return $ InlineAssignment [c] n e + expr :: SourcePos -> Parser (ExpressionStart SourcePos) + expr c = do + e <- sourceParser + return $ ParensExpression [c] e + builtinCall = do + c <- getPosition + n <- builtinFunction + f <- parseFunctionCall c n + return $ BuiltinCall [c] f + builtinValue = do + c <- getPosition + n <- builtinValues + return $ NamedVariable (OutputValue [c] (VariableName n)) + variableOrUnqualified = do + c <- getPosition + n <- sourceParser :: Parser VariableName + asUnqualifiedCall c n <|> asVariable c n + asVariable c n = do + return $ NamedVariable (OutputValue [c] n) + asUnqualifiedCall c n = do + f <- parseFunctionCall c (FunctionName (vnName n)) + return $ UnqualifiedCall [c] f + typeOrCategoryCall = do + c <- getPosition + t <- sourceParser :: Parser CategoryName + asType c t <|> asCategory c t + asType c t = do + try typeSymbolGet + n <- sourceParser + f <- parseFunctionCall c n + return $ TypeCall [c] (JustTypeInstance $ TypeInstance t $ Positional []) f + asCategory c t = do + categorySymbolGet + n <- sourceParser + f <- parseFunctionCall c n + return $ CategoryCall [c] t f + typeCall = do + c <- getPosition + t <- try sourceParser + try typeSymbolGet + n <- sourceParser + f <- parseFunctionCall c n + return $ TypeCall [c] t f + +instance ParseFromSource (ValueLiteral SourcePos) where + sourceParser = labeled "literal" $ + stringLiteral <|> + charLiteral <|> + escapedInteger <|> + integerOrDecimal <|> + boolLiteral <|> + emptyLiteral where + stringLiteral = do + c <- getPosition + string "\"" + ss <- manyTill stringChar (string "\"") + optionalSpace + return $ StringLiteral [c] ss + charLiteral = do + c <- getPosition + string "'" + ch <- stringChar + string "'" + optionalSpace + return $ CharLiteral [c] ch + escapedInteger = do + c <- getPosition + escapeStart + b <- oneOf "bBoOdDxX" + d <- case b of + 'b' -> parseBin + 'B' -> parseBin + 'o' -> parseOct + 'O' -> parseOct + 'd' -> parseDec + 'D' -> parseDec + 'x' -> parseHex + 'X' -> parseHex + optionalSpace + return $ IntegerLiteral [c] True d + integerOrDecimal = do + c <- getPosition + d <- parseDec + decimal c d <|> integer c d + decimal c d = do + char '.' + (n,d2) <- parseSubOne + e <- decExponent <|> return 0 + optionalSpace + return $ DecimalLiteral [c] (d*10^n + d2) (e - n) + decExponent = do + string "e" <|> string "E" + s <- (string "+" >> return 1) <|> (string "-" >> return (-1)) <|> return 1 + e <- parseDec + return (s*e) + integer c d = do + optionalSpace + return $ IntegerLiteral [c] False d + boolLiteral = do + c <- getPosition + b <- try $ (kwTrue >> return True) <|> (kwFalse >> return False) + return $ BoolLiteral [c] b + emptyLiteral = do + c <- getPosition + try kwEmpty + return $ EmptyLiteral [c] + +instance ParseFromSource (ValueOperation SourcePos) where + sourceParser = try valueCall <|> try conversion where + valueCall = labeled "function call" $ do + c <- getPosition + valueSymbolGet + n <- sourceParser + f <- parseFunctionCall c n + return $ ValueCall [c] f + conversion = labeled "type conversion" $ do + c <- getPosition + valueSymbolGet + t <- sourceParser -- NOTE: Should not need try here. + typeSymbolGet + n <- sourceParser + f <- parseFunctionCall c n + return $ ConvertedCall [c] t f diff --git a/src/Parser/SourceFile.hs b/src/Parser/SourceFile.hs new file mode 100644 --- /dev/null +++ b/src/Parser/SourceFile.hs @@ -0,0 +1,58 @@ +{- ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Parser.SourceFile ( + parseInternalSource, + parsePublicSource, + parseTestSource, +) where + +import Text.Parsec +import Text.Parsec.String + +import Base.CompileError +import Parser.Common +import Parser.DefinedCategory +import Parser.IntegrationTest +import Parser.TypeCategory +import Types.DefinedCategory +import Types.IntegrationTest +import Types.Positional +import Types.TypeCategory + + +parseInternalSource :: CompileErrorM m => + (String,String) -> m ([AnyCategory SourcePos],[DefinedCategory SourcePos]) +parseInternalSource (f,s) = unwrap parsed where + parsed = parse (between optionalSpace endOfDoc parseAnySource) f s + unwrap (Left e) = compileError (show e) + unwrap (Right t) = return t + +parsePublicSource :: CompileErrorM m => (String,String) -> m [AnyCategory SourcePos] +parsePublicSource (f,s) = unwrap parsed where + parsed = parse (between optionalSpace endOfDoc (sepBy sourceParser optionalSpace)) f s + unwrap (Left e) = compileError (show e) + unwrap (Right t) = return t + +parseTestSource :: CompileErrorM m => (String,String) -> m [IntegrationTest SourcePos] +parseTestSource (f,s) = unwrap parsed where + parsed = parse (between optionalSpace endOfDoc (sepBy sourceParser optionalSpace)) f s + unwrap (Left e) = compileError (show e) + unwrap (Right t) = return t diff --git a/src/Parser/TypeCategory.hs b/src/Parser/TypeCategory.hs new file mode 100644 --- /dev/null +++ b/src/Parser/TypeCategory.hs @@ -0,0 +1,198 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} + +module Parser.TypeCategory ( + parseFilters, + parseScope, + parseScopedFunction, + singleDefine, + singleFilter, + singleRefine, +) where + +import Text.Parsec +import Text.Parsec.String + +import Parser.Common +import Parser.TypeInstance +import Types.Positional +import Types.TypeCategory +import Types.TypeInstance +import Types.Variance + + +instance ParseFromSource (AnyCategory SourcePos) where + sourceParser = parseValue <|> parseInstance <|> parseConcrete where + open = sepAfter $ string "{" + close = sepAfter $ string "}" + parseValue = labeled "value interface" $ do + c <- getPosition + try $ kwValue >> kwInterface + n <- sourceParser + ps <- parseCategoryParams + open + (rs,vs) <- parseRefinesFilters + fs <- flip sepBy optionalSpace $ parseScopedFunction (return ValueScope) (return n) + close + return $ ValueInterface [c] NoNamespace n ps rs vs fs + parseInstance = labeled "type interface" $ do + c <- getPosition + try $ kwType >> kwInterface + n <- sourceParser + ps <- parseCategoryParams + open + vs <- parseFilters + fs <- flip sepBy optionalSpace $ parseScopedFunction (return TypeScope) (return n) + close + return $ InstanceInterface [c] NoNamespace n ps vs fs + parseConcrete = labeled "concrete type" $ do + c <- getPosition + try kwConcrete + n <- sourceParser + ps <- parseCategoryParams + open + (rs,ds,vs) <- parseRefinesDefinesFilters + fs <- flip sepBy optionalSpace $ parseScopedFunction parseScope (return n) + close + return $ ValueConcrete [c] NoNamespace n ps rs ds vs fs + +parseCategoryParams :: Parser [ValueParam SourcePos] +parseCategoryParams = do + (con,inv,cov) <- none <|> try fixedOnly <|> try noFixed <|> try explicitFixed + return $ map (apply Contravariant) con ++ + map (apply Invariant) inv ++ + map (apply Covariant) cov + where + none = do + notFollowedBy (string "<") + return ([],[],[]) + fixedOnly = do -- T + inv <- between (sepAfter $ string "<") + (sepAfter $ string ">") + (sepBy singleParam (sepAfter $ string ",")) + return ([],inv,[]) + noFixed = do -- T + con <- between (sepAfter $ string "<") + (sepAfter $ string "|") + (sepBy singleParam (sepAfter $ string ",")) + cov <- between nullParse + (sepAfter $ string ">") + (sepBy singleParam (sepAfter $ string ",")) + return (con,[],cov) + explicitFixed = do -- T + con <- between (sepAfter $ string "<") + (sepAfter $ string "|") + (sepBy singleParam (sepAfter $ string ",")) + inv <- between nullParse + (sepAfter $ string "|") + (sepBy singleParam (sepAfter $ string ",")) + cov <- between nullParse + (sepAfter $ string ">") + (sepBy singleParam (sepAfter $ string ",")) + return (con,inv,cov) + singleParam = labeled "param declaration" $ do + c <- getPosition + n <- sourceParser + return (c,n) + apply v (c,n) = ValueParam [c] n v + +singleRefine :: Parser (ValueRefine SourcePos) +singleRefine = do + c <- getPosition + try kwRefines + t <- sourceParser + return $ ValueRefine [c] t + +singleDefine :: Parser (ValueDefine SourcePos) +singleDefine = do + c <- getPosition + try kwDefines + t <- sourceParser + return $ ValueDefine [c] t + +singleFilter :: Parser (ParamFilter SourcePos) +singleFilter = try $ do + c <- getPosition + n <- sourceParser + f <- sourceParser + return $ ParamFilter [c] n f + +parseCategoryRefines :: Parser [ValueRefine SourcePos] +parseCategoryRefines = sepAfter $ sepBy singleRefine optionalSpace + +parseFilters :: Parser [ParamFilter SourcePos] +parseFilters = sepBy singleFilter optionalSpace + +parseRefinesFilters :: Parser ([ValueRefine SourcePos],[ParamFilter SourcePos]) +parseRefinesFilters = parsed >>= return . merge2 where + parsed = sepBy anyType optionalSpace + anyType = labeled "refine or param filter" $ put12 singleRefine <|> put22 singleFilter + +parseRefinesDefinesFilters :: Parser ([ValueRefine SourcePos], + [ValueDefine SourcePos], + [ParamFilter SourcePos]) +parseRefinesDefinesFilters = parsed >>= return . merge3 where + parsed = sepBy anyType optionalSpace + anyType = + labeled "refine or define or param filter" $ put13 singleRefine <|> put23 singleDefine <|> put33 singleFilter + +instance ParseFromSource FunctionName where + sourceParser = labeled "function name" $ do + noKeywords + b <- lower + e <- sepAfter $ many alphaNum + return $ FunctionName (b:e) + +parseScopedFunction :: Parser SymbolScope -> Parser CategoryName -> + Parser (ScopedFunction SourcePos) +parseScopedFunction sp tp = labeled "function" $ do + c <- getPosition + s <- try sp -- Could be a constant, i.e., nothing consumed. + t <- try tp -- Same here. + n <- try sourceParser + ps <- fmap Positional $ noParams <|> someParams + fa <- parseFilters + as <- fmap Positional $ typeList "argument type" + sepAfter $ string "->" + rs <- fmap Positional $ typeList "return type" + return $ ScopedFunction [c] n t s as rs ps fa [] + where + noParams = notFollowedBy (string "<") >> return [] + someParams = between (sepAfter $ string "<") + (sepAfter $ string ">") + (sepBy singleParam (sepAfter $ string ",")) + singleParam = labeled "param declaration" $ do + c <- getPosition + n <- sourceParser + return $ ValueParam [c] n Invariant + typeList l = between (sepAfter $ string "(") + (sepAfter $ string ")") + (sepBy (labeled l $ singleType) (sepAfter $ string ",")) + singleType = do + c <- getPosition + t <- sourceParser + return $ PassedValue [c] t + +parseScope :: Parser SymbolScope +parseScope = try categoryScope <|> try typeScope <|> valueScope +categoryScope = kwCategory >> return CategoryScope +typeScope = kwType >> return TypeScope +valueScope = kwValue >> return ValueScope diff --git a/src/Parser/TypeInstance.hs b/src/Parser/TypeInstance.hs new file mode 100644 --- /dev/null +++ b/src/Parser/TypeInstance.hs @@ -0,0 +1,139 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} + +module Parser.TypeInstance ( +) where + +import Control.Applicative ((<|>)) +import Control.Monad (when) +import Text.Parsec hiding ((<|>)) +import Text.Parsec.String + +import Parser.Common +import Types.GeneralType +import Types.Positional +import Types.TypeInstance + + +instance ParseFromSource GeneralInstance where + sourceParser = try all <|> try any <|> intersectOrUnion <|> single where + all = labeled "all" $ do + kwAll + return $ TypeMerge MergeUnion [] + any = labeled "any" $ do + kwAny + return $ TypeMerge MergeIntersect [] + intersectOrUnion = try intersect <|> union + intersect = labeled "intersection" $ do + ts <- between (sepAfter $ string "[") + (sepAfter $ string "]") + (sepBy1 (labeled "type" $ sourceParser) (sepAfter $ string "&")) + return $ TypeMerge MergeIntersect ts + union = labeled "union" $ do + ts <- between (sepAfter $ string "[") + (sepAfter $ string "]") + (sepBy1 (labeled "type" $ sourceParser) (sepAfter $ string "|")) + return $ TypeMerge MergeUnion ts + single = do + t <- sourceParser + return $ SingleType t + +instance ParseFromSource ValueType where + sourceParser = do + r <- getWeak <|> getOptional <|> getRequired + t <- sourceParser + return $ ValueType r t + where + getWeak = labeled "weak" $ do + try kwWeak + return WeakValue + getOptional = labeled "optional" $ do + try kwOptional + return OptionalValue + getRequired = return RequiredValue + +instance ParseFromSource CategoryName where + sourceParser = labeled "type name" $ do + noKeywords + b <- upper + e <- sepAfter $ many alphaNum + return $ box (b:e) + where + box n + | n == "Bool" = BuiltinBool + | n == "Char" = BuiltinChar + | n == "Int" = BuiltinInt + | n == "Float" = BuiltinFloat + | n == "String" = BuiltinString + | n == "Formatted" = BuiltinFormatted + | otherwise = CategoryName n + +instance ParseFromSource ParamName where + sourceParser = labeled "param name" $ do + noKeywords + char '#' + b <- lower + e <- sepAfter $ many alphaNum + return $ ParamName ('#':b:e) + +instance ParseFromSource TypeInstance where + sourceParser = labeled "type" $ do + n <- sourceParser + as <- labeled "type args" $ try args <|> return [] + return $ TypeInstance n (Positional as) + where + args = between (sepAfter $ string "<") + (sepAfter $ string ">") + (sepBy sourceParser (sepAfter $ string ",")) + +instance ParseFromSource DefinesInstance where + sourceParser = labeled "type" $ do + n <- sourceParser + as <- labeled "type args" $ try args <|> return [] + return $ DefinesInstance n (Positional as) + where + args = between (sepAfter $ string "<") + (sepAfter $ string ">") + (sepBy sourceParser (sepAfter $ string ",")) + +instance ParseFromSource TypeInstanceOrParam where + sourceParser = try param <|> inst where + param = labeled "param" $ do + n <- sourceParser + return $ JustParamName n + inst = labeled "type" $ do + t <- sourceParser + return $ JustTypeInstance t + +instance ParseFromSource TypeFilter where + sourceParser = requires <|> allows <|> defines where + requires = labeled "requires filter" $ do + try kwRequires + t <- sourceParser + return $ TypeFilter FilterRequires t + allows = labeled "allows filter" $ do + try kwAllows + t <- sourceParser + return $ TypeFilter FilterAllows t + defines = labeled "defines filter" $ do + try kwDefines + t <- sourceParser + return $ DefinesFilter t diff --git a/src/Test/Common.hs b/src/Test/Common.hs new file mode 100644 --- /dev/null +++ b/src/Test/Common.hs @@ -0,0 +1,200 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Test.Common ( + checkDefinesFail, + checkDefinesSuccess, + checkEquals, + checkTypeFail, + checkTypeSuccess, + containsAtLeast, + containsAtMost, + containsExactly, + containsNoDuplicates, + forceParse, + loadFile, + parseFilterMap, + parseTheTest, + readMulti, + readSingle, + readSingleWith, + runAllTests, + showParams, +) where + +import Data.Either +import Data.List +import System.FilePath +import System.IO +import Text.Parsec +import Text.Parsec.String +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Base.CompileError +import Base.Mergeable +import Compilation.CompileInfo +import Parser.Common +import Parser.TypeInstance +import Types.TypeInstance + + +runAllTests :: [IO (CompileInfo ())] -> IO () +runAllTests ts = do + results <- sequence ts + let (es,ps) = partitionEithers $ zipWith numberError [1..] results + mapM_ (\(n,e) -> hPutStr stderr ("Test " ++ show n ++ ": " ++ show e ++ "\n")) es + hPutStr stderr $ show (length ps) ++ " tests passed + " ++ + show (length es) ++ " tests failed\n" + +numberError :: a -> CompileInfo b -> Either (a,CompileMessage) b +numberError n c + | isCompileError c = Left (n,getCompileError c) + | otherwise = Right (getCompileSuccess c) + +forceParse :: ParseFromSource a => String -> a +forceParse s = force $ parse sourceParser "(string)" s where + force (Right x) = x + +readSingle :: (ParseFromSource a, CompileErrorM m) => String -> String -> m a +readSingle = readSingleWith (optionalSpace >> sourceParser) + +readSingleWith :: CompileErrorM m => Parser a -> String -> String -> m a +readSingleWith p f s = + unwrap $ parse (between nullParse endOfDoc p) f s + where + unwrap (Left e) = compileError (show e) + unwrap (Right t) = return t + +readMulti :: CompileErrorM m => ParseFromSource a => String -> String -> m [a] +readMulti f s = + unwrap $ parse (between optionalSpace endOfDoc (sepBy sourceParser optionalSpace)) f s + where + unwrap (Left e) = compileError (show e) + unwrap (Right t) = return t + +parseFilterMap :: CompileErrorM m => [(String,[String])] -> m ParamFilters +parseFilterMap pa = do + pa2 <- collectAllOrErrorM $ map parseFilters pa + return $ Map.fromList pa2 + where + parseFilters (n,fs) = do + fs2 <- collectAllOrErrorM $ map (readSingle "(string)") fs + return (ParamName n,fs2) + +parseTheTest :: (ParseFromSource a, CompileErrorM m) => + [(String,[String])] -> [String] -> m ([a],ParamFilters) +parseTheTest pa xs = do + ts <- collectAllOrErrorM $ map (readSingle "(string)") xs + pa2 <- parseFilterMap pa + return (ts,pa2) + +showParams :: [(String,[String])] -> String +showParams pa = "[" ++ intercalate "," (concat $ map expand pa) ++ "]" where + expand (n,ps) = map (\p -> n ++ " " ++ p) ps + +checkTypeSuccess :: (TypeResolver r) => + r -> [(String,[String])] -> String -> CompileInfo () +checkTypeSuccess r pa x = do + ([t],pa2) <- parseTheTest pa [x] + check $ validateGeneralInstance r pa2 t + where + prefix = x ++ " " ++ showParams pa + check = flip reviseError (prefix ++ ":") + +checkTypeFail :: (TypeResolver r) => + r -> [(String,[String])] -> String -> CompileInfo () +checkTypeFail r pa x = do + ([t],pa2) <- parseTheTest pa [x] + check $ validateGeneralInstance r pa2 t + where + prefix = x ++ " " ++ showParams pa + check :: CompileInfo a -> CompileInfo () + check c + | isCompileError c = return () + | otherwise = compileError $ prefix ++ ": Expected failure\n" + +checkDefinesSuccess :: (TypeResolver r) => + r -> [(String,[String])] -> String -> CompileInfo () +checkDefinesSuccess r pa x = do + ([t],pa2) <- parseTheTest pa [x] + check $ validateDefinesInstance r pa2 t + where + prefix = x ++ " " ++ showParams pa + check = flip reviseError (prefix ++ ":") + +checkDefinesFail :: (TypeResolver r) => + r -> [(String,[String])] -> String -> CompileInfo () +checkDefinesFail r pa x = do + ([t],pa2) <- parseTheTest pa [x] + check $ validateDefinesInstance r pa2 t + where + prefix = x ++ " " ++ showParams pa + check :: CompileInfo a -> CompileInfo () + check c + | isCompileError c = return () + | otherwise = compileError $ prefix ++ ": Expected failure\n" + +containsExactly :: (Ord a, Show a, MergeableM m, CompileErrorM m) => + [a] -> [a] -> m () +containsExactly actual expected = do + containsNoDuplicates actual + containsAtLeast actual expected + containsAtMost actual expected + +containsNoDuplicates :: (Ord a, Show a, MergeableM m, CompileErrorM m) => + [a] -> m () +containsNoDuplicates expected = + (mergeAllM $ map checkSingle $ group $ sort expected) `reviseError` (show expected) + where + checkSingle xa@(x:_:_) = + compileError $ "Item " ++ show x ++ " occurs " ++ show (length xa) ++ " times" + checkSingle _ = return () + +containsAtLeast :: (Ord a, Show a, MergeableM m, CompileErrorM m) => + [a] -> [a] -> m () +containsAtLeast actual expected = + (mergeAllM $ map (checkInActual $ Set.fromList actual) expected) `reviseError` + (show actual ++ " (actual) vs. " ++ show expected ++ " (expected)") + where + checkInActual va v = + if v `Set.member` va + then return () + else compileError $ "Item " ++ show v ++ " was expected but not present" + +containsAtMost :: (Ord a, Show a, MergeableM m, CompileErrorM m) => + [a] -> [a] -> m () +containsAtMost actual expected = + (mergeAllM $ map (checkInExpected $ Set.fromList expected) actual) `reviseError` + (show actual ++ " (actual) vs. " ++ show expected ++ " (expected)") + where + checkInExpected va v = + if v `Set.member` va + then return () + else compileError $ "Item " ++ show v ++ " is unexpected" + +checkEquals :: (Eq a, Show a, MergeableM m, CompileErrorM m) => + a -> a -> m () +checkEquals actual expected + | actual == expected = return () + | otherwise = compileError $ "Expected " ++ show expected ++ " but got " ++ show actual + +loadFile :: String -> IO String +loadFile f = readFile ("src" "Test" f) diff --git a/src/Test/DefinedCategory.hs b/src/Test/DefinedCategory.hs new file mode 100644 --- /dev/null +++ b/src/Test/DefinedCategory.hs @@ -0,0 +1,59 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Test.DefinedCategory (tests) where + +import System.FilePath +import Text.Parsec +import Text.Parsec.String + +import Base.CompileError +import Compilation.CompileInfo +import Parser.DefinedCategory +import Test.Common +import Types.DefinedCategory + + +tests :: [IO (CompileInfo ())] +tests = [ + checkParseSuccess ("testfiles" "definitions.0rx"), + checkParseSuccess ("testfiles" "internal_inheritance.0rx"), + checkParseSuccess ("testfiles" "internal_params.0rx"), + checkParseSuccess ("testfiles" "internal_filters.0rx") + ] + +checkParseSuccess f = do + contents <- loadFile f + let parsed = readMulti f contents :: CompileInfo [DefinedCategory SourcePos] + return $ check parsed + where + check c + | isCompileError c = compileError $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c) + | otherwise = return () + +checkParseFail f = do + contents <- loadFile f + let parsed = readMulti f contents :: CompileInfo [DefinedCategory SourcePos] + return $ check parsed + where + check c + | isCompileError c = return () + | otherwise = compileError $ "Parse " ++ f ++ ": Expected failure but got\n" ++ + show (getCompileSuccess c) ++ "\n" diff --git a/src/Test/IntegrationTest.hs b/src/Test/IntegrationTest.hs new file mode 100644 --- /dev/null +++ b/src/Test/IntegrationTest.hs @@ -0,0 +1,124 @@ +{- ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Test.IntegrationTest (tests) where + +import Control.Monad (when) +import System.FilePath +import Text.Parsec + +import Base.CompileError +import Compilation.CompileInfo +import Parser.Common +import Parser.IntegrationTest +import Test.Common +import Types.DefinedCategory +import Types.IntegrationTest +import Types.Positional +import Types.Procedure +import Types.TypeCategory +import Types.TypeInstance + + +tests :: [IO (CompileInfo ())] +tests = [ + checkFileContents + ("testfiles" "basic_error_test.0rt") + (\t -> return $ do + let h = itHeader t + when (not $ isExpectCompileError $ ithResult h) $ compileError "Expected ExpectCompileError" + checkEquals (ithTestName h) "basic error test" + containsExactly (getRequirePattern $ ithResult h) [ + OutputPattern OutputCompiler "pattern in output 1", + OutputPattern OutputAny "pattern in output 2" + ] + containsExactly (getExcludePattern $ ithResult h) [ + OutputPattern OutputStderr "pattern not in output 1", + OutputPattern OutputStdout "pattern not in output 2" + ] + containsExactly (extractCategoryNames t) ["Test"] + containsExactly (extractDefinitionNames t) ["Test"] + ), + + checkFileContents + ("testfiles" "basic_crash_test.0rt") + (\t -> return $ do + let h = itHeader t + when (not $ isExpectRuntimeError $ ithResult h) $ compileError "Expected ExpectRuntimeError" + checkEquals (ithTestName h) "basic crash test" + let match = case ereExpression $ ithResult h of + (Expression _ + (TypeCall _ + (JustTypeInstance (TypeInstance (CategoryName "Test") (Positional []))) + (FunctionCall _ (FunctionName "execute") (Positional []) (Positional []))) []) -> True + _ -> False + when (not match) $ compileError "Expected test expression \"Test$execute()\"" + containsExactly (getRequirePattern $ ithResult h) [ + OutputPattern OutputAny "pattern in output 1", + OutputPattern OutputAny "pattern in output 2" + ] + containsExactly (getExcludePattern $ ithResult h) [ + OutputPattern OutputAny "pattern not in output 1", + OutputPattern OutputAny "pattern not in output 2" + ] + containsExactly (extractCategoryNames t) ["Test"] + containsExactly (extractDefinitionNames t) ["Test"] + ), + + checkFileContents + ("testfiles" "basic_success_test.0rt") + (\t -> return $ do + let h = itHeader t + when (not $ isExpectRuntimeSuccess $ ithResult h) $ compileError "Expected ExpectRuntimeSuccess" + checkEquals (ithTestName h) "basic success test" + let match = case ersExpression $ ithResult h of + (Expression _ + (TypeCall _ + (JustTypeInstance (TypeInstance (CategoryName "Test") (Positional []))) + (FunctionCall _ (FunctionName "execute") (Positional []) (Positional []))) []) -> True + _ -> False + when (not match) $ compileError "Expected test expression \"Test$execute()\"" + containsExactly (getRequirePattern $ ithResult h) [ + OutputPattern OutputAny "pattern in output 1", + OutputPattern OutputAny "pattern in output 2" + ] + containsExactly (getExcludePattern $ ithResult h) [ + OutputPattern OutputAny "pattern not in output 1", + OutputPattern OutputAny "pattern not in output 2" + ] + containsExactly (extractCategoryNames t) ["Test"] + containsExactly (extractDefinitionNames t) ["Test"] + ) + ] + +checkFileContents :: + String -> (IntegrationTest SourcePos -> IO (CompileInfo ())) -> IO (CompileInfo ()) +checkFileContents f o = do + s <- loadFile f + unwrap $ parse (between optionalSpace endOfDoc sourceParser) f s + where + unwrap (Left e) = return $ compileError (show e) + unwrap (Right t) = fmap (flip reviseError ("Check " ++ f ++ ":")) $ o t + +extractCategoryNames :: IntegrationTest c -> [String] +extractCategoryNames = map (show . getCategoryName) . itCategory + +extractDefinitionNames :: IntegrationTest c -> [String] +extractDefinitionNames = map (show . dcName) . itDefinition diff --git a/src/Test/Parser.hs b/src/Test/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Test/Parser.hs @@ -0,0 +1,79 @@ +{- ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Test.Parser (tests) where + +import Control.Monad (when) +import Text.Parsec +import Text.Parsec.String + +import Base.CompileError +import Compilation.CompileInfo +import Parser.Common +import Test.Common + + +tests :: [IO (CompileInfo ())] +tests = [ + checkParsesAs stringChar "\\'" '\'', + checkParsesAs stringChar "\\\"" '"', + checkParsesAs stringChar "\\?" '?', + checkParsesAs stringChar "\\\\" '\\', + checkParsesAs stringChar "\\a" '\a', + checkParsesAs stringChar "\\b" '\b', + checkParsesAs stringChar "\\f" '\f', + checkParsesAs stringChar "\\n" '\n', + checkParsesAs stringChar "\\r" '\r', + checkParsesAs stringChar "\\t" '\t', + checkParsesAs stringChar "\\v" '\v', + checkParsesAs stringChar "\n" '\n', + checkParsesAs stringChar "\\x0A" '\n', + checkParsesAs stringChar "\\012" '\n', + checkParseFail stringChar "\"", + checkParseFail stringChar "\\q", + checkParseFail stringChar "\\00", + checkParseFail stringChar "\\x0", + + checkParsesAs regexChar "\\\\" "\\\\", + checkParsesAs regexChar "\\n" "\\n", + checkParsesAs regexChar "\n" "\n", + checkParsesAs regexChar "\\\"" "\"", + checkParseFail regexChar "\"" + ] + +checkParsesAs p s m = return $ do + let parsed = readSingleWith p "(string)" s + check parsed + e <- parsed + when (e /= m) $ + compileError $ show s ++ " does not parse as " ++ show m ++ ":\n" ++ show e + where + check c + | isCompileError c = compileError $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c) + | otherwise = return () + +checkParseFail p s = do + let parsed = readSingleWith p "(string)" s + return $ check parsed + where + check c + | isCompileError c = return () + | otherwise = compileError $ "Parse '" ++ s ++ "': Expected failure but got\n" ++ + show (getCompileSuccess c) ++ "\n" diff --git a/src/Test/Procedure.hs b/src/Test/Procedure.hs new file mode 100644 --- /dev/null +++ b/src/Test/Procedure.hs @@ -0,0 +1,443 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Test.Procedure (tests) where + +import Control.Monad +import System.FilePath +import Text.Parsec +import Text.Parsec.String + +import Base.CompileError +import Compilation.CompileInfo +import Parser.Procedure +import Test.Common +import Types.Positional +import Types.Procedure +import Types.TypeCategory +import Types.TypeInstance + + +tests :: [IO (CompileInfo ())] +tests = [ + checkParseSuccess ("testfiles" "procedures.0rx"), + + checkShortParseSuccess "return _", + checkShortParseSuccess "return var", + checkShortParseFail "return var var", + checkShortParseFail "return _ var", + checkShortParseSuccess "return call()", + checkShortParseSuccess "return var.T<#x>$func()", + checkShortParseSuccess "return { var, var.T<#x>$func() }", + checkShortParseFail "return { var var.T<#x>$func() }", + checkShortParseFail "return { var, _ }", + checkShortParseFail "return T<#x> var", + checkShortParseSuccess "return T<#x>{ val }", + checkShortParseSuccess "~ T$$func()", + checkShortParseFail "~ T<#x>$$func()", + checkShortParseFail "~ var.T$$func()", + checkShortParseFail "~ T$ $func()", + + checkShortParseSuccess "break", + checkShortParseFail "break var", + checkShortParseFail "break _", + checkShortParseFail "break { }", + + checkShortParseSuccess "~ var", + checkShortParseFail "~ var var", + checkShortParseSuccess "~ var.T<#x>$func().func2().func3()", + checkShortParseSuccess "~ T<#x>$func().func2().func3()", + checkShortParseSuccess "~ #x$func().func2().func3()", + checkShortParseFail "~ var.T<#x>.T<#x>$func()", + checkShortParseFail "~ var.T<#x>$T<#x>$func()", + checkShortParseFail "~ T<#x>$func()$func2()", + checkShortParseFail "~ var$func2()", + checkShortParseFail "~ var.T<#x>", + checkShortParseFail "~ T<#x> var", + checkShortParseSuccess "~ T<#x>{ val, var.T<#x>$func() }", + checkShortParseFail "~ T<#x>{ val var.T<#x>$func() }", + checkShortParseFail "~ T<#x>{}.call()", + checkShortParseSuccess "~ (T<#x>{}).call()", + + checkShortParseSuccess "x <- var.func()", + checkShortParseFail "x <- var.func() var.func()", + checkShortParseFail "x <- y <- var.func()", + checkShortParseSuccess "x <- empty", + checkShortParseSuccess "x <- true", + checkShortParseSuccess "x <- false", + checkShortParseSuccess "x <- require(y)", + checkShortParseSuccess "x <- reduce<#x,#y>(z)", + checkShortParseSuccess "x <- self", + checkShortParseSuccess "x <- self.f()", + checkShortParseFail "empty <- x", + checkShortParseFail "true <- x", + checkShortParseFail "false <- x", + checkShortParseFail "require <- x", + checkShortParseFail "reduce <- x", + checkShortParseFail "self <- x", + checkShortParseFail "T<#x> empty <- x", + checkShortParseFail "T<#x> true <- x", + checkShortParseFail "T<#x> false <- x", + checkShortParseFail "T<#x> require <- x", + checkShortParseFail "T<#x> reduce <- x", + checkShortParseFail "T<#x> self <- x", + checkShortParseSuccess "T<#x> x <- var.func()", + checkShortParseSuccess "weak T<#x> x <- var.func()", + checkShortParseFail "~ T<#x> x <- var.func()", + checkShortParseSuccess "{ _, weak T<#x> x } <- var.func()", + checkShortParseFail "{ _, weak T<#x> x } <- T<#x> x", + + checkShortParseSuccess "if (var.func()) { ~ val.call() }", + checkShortParseSuccess "if (present(var)) { ~ val.call() }", + checkShortParseFail "if (T<#x> x) { ~ val.call() }", + checkShortParseSuccess "if (var) { ~ val.call() } else { ~ val.call() }", + checkShortParseFail "if (var) { ~ val.call() } elif { ~ val.call() }", + checkShortParseSuccess "if (v) { ~ c() } elif (v) { ~ c() }", + checkShortParseSuccess "if (v) { ~ c() } elif (v) { ~ c() } else { ~ c() }", + checkShortParseSuccess "if (v) { ~ c() } elif (v) { ~ c() } elif (v) { ~ c() }", + + checkShortParseSuccess "while (var.func()) { ~ val.call() }", + checkShortParseSuccess "while (var.func()) { ~ val.call() } update { ~ call() }", + + checkShortParseSuccess "scoped { T<#x> x <- y } in return _", + checkShortParseSuccess "scoped { T<#x> x <- y } in return { var, var.T<#x>$func() }", + checkShortParseSuccess "scoped { T<#x> x <- y } in ~ var.T<#x>$func()", + checkShortParseSuccess "scoped { T<#x> x <- y } in { _, weak T<#x> x } <- var.func()", + + checkShortParseSuccess "scoped { T<#x> x <- y } in if (var.func()) { ~ val.call() }", + checkShortParseSuccess "scoped { T<#x> x <- y } in while (var.func()) { ~ val.call() }", + + checkShortParseSuccess "x <- (((var.func())).T$call())", + checkShortParseSuccess "~ (x <- var).func()", + checkShortParseFail "x <- (((var.func()))", + checkShortParseFail "(((x <- var.func())))", + checkShortParseFail "(x) <- y", + checkShortParseFail "T (x) <- y", + checkShortParseFail "~ (T x <- var).func()", + checkShortParseSuccess "~ call(((var.func())).T$call())", + checkShortParseSuccess "if (((var.func()).T$call())) { }", + checkShortParseSuccess "fail(\"reason\")", + checkShortParseFail "~ fail(\"reason\")", + checkShortParseSuccess "failed <- 10", + + checkShortParseSuccess "~var.T<#x>$func().func2().func3()", + checkShortParseSuccess "~T<#x>{val,var.T<#x>$func()}", + checkShortParseSuccess "x<-var.func()", + checkShortParseSuccess "T<#x>x<-var.func()", + checkShortParseSuccess "{_,weak T<#x>x}<-var.func()", + checkShortParseSuccess "if(v){~c()}elif(v){~c()}", + checkShortParseSuccess "if(v){~c()}elif(v){~c()}else{~c()}", + checkShortParseSuccess "if(v){~c()}elif(v){~c()}elif(v){~c()}", + checkShortParseSuccess "while(var.func()){~val.call()}", + checkShortParseSuccess "scoped{T<#x>x<-y}in~var.T<#x>$func()", + checkShortParseSuccess "scoped{T<#x>x<-y}in{x<-1}", + checkShortParseSuccess "scoped{T<#x>x<-y}in{x}<-1", + checkShortParseFail "scoped{T<#x>x<-y}in{x}", + + checkShortParseSuccess "x <- !y", + checkShortParseSuccess "x <- !y", + checkShortParseFail "x <- !!=y", + checkShortParseSuccess "x <- (!y).func()", + checkShortParseSuccess "~ !y", + checkShortParseSuccess "if (!y) { }", + + checkShortParseSuccess "~ !x + !y", + checkShortParseSuccess "~ !x - !y", + checkShortParseSuccess "~ !x * !y", + checkShortParseSuccess "~ !x / !y", + checkShortParseSuccess "~ !x % !y", + checkShortParseSuccess "~ !x == !y", + checkShortParseSuccess "~ !x != !y", + checkShortParseSuccess "~ !x < !y", + checkShortParseSuccess "~ !x <= !y", + checkShortParseSuccess "~ !x > !y", + checkShortParseSuccess "~ !x >= !y", + checkShortParseSuccess "~ !x && !y", + checkShortParseSuccess "~ !x || !y", + + checkShortParseSuccess "x <- y + z", + checkShortParseSuccess "x <- !y == !z", + checkShortParseSuccess "x <- (x + y) / z", + checkShortParseSuccess "~ x <= y", + checkShortParseFail "~ x < <- y", + + checkShortParseSuccess "x <- 123 + 123", + checkShortParseSuccess "x <- 123.0 - 123.0", + checkShortParseFail "x <- 123.", + checkShortParseSuccess "x <- 0.123 * 0.123", + checkShortParseFail "x <- .123", + checkShortParseSuccess "x <- 12.3 / 12.3", + checkShortParseFail "x <- 12.3.", + checkShortParseSuccess "x <- 12.3 + -456.7", + checkShortParseSuccess "x <- \\x123aBc + \\x123aBc", + checkShortParseFail "x <- \\x123aQc", + checkShortParseFail "x <- \\x", + checkShortParseFail "x <- \\x1.2", + checkShortParseSuccess "x <- \" return \\\"\\\" \" + \"1fds\"", + checkShortParseFail "x <- \"fsdfd", + checkShortParseFail "x <- \"\"fsdfd", + checkShortParseSuccess "x <- 123.0 + z.call()", + checkShortParseFail "x <- \"123\".call()", + checkShortParseFail "x <- 123.call()", + checkShortParseSuccess " x <- 'x'", + checkShortParseSuccess " x <- '\\xAA'", + checkShortParseFail " x <- '\\xAAZ'", + checkShortParseSuccess " x <- '\076'", + checkShortParseFail " x <- '\\07'", + checkShortParseSuccess " x <- '\\n'", + checkShortParseFail " x <- 'x", + checkShortParseFail " x <- 'xx'", + checkShortParseSuccess " x <- \"'xx\"", + + checkParsesAs "1 + 2 < 4 && 3 >= 1 * 2 + 1 || true" + (\e -> case e of + (InfixExpression _ + (InfixExpression _ + (InfixExpression _ + (InfixExpression _ + (Literal (IntegerLiteral _ False 1)) (NamedOperator "+") + (Literal (IntegerLiteral _ False 2))) (NamedOperator "<") + (Literal (IntegerLiteral _ False 4))) (NamedOperator "&&") + (InfixExpression _ + (Literal (IntegerLiteral _ False 3)) (NamedOperator ">=") + (InfixExpression _ + (InfixExpression _ + (Literal (IntegerLiteral _ False 1)) (NamedOperator "*") + (Literal (IntegerLiteral _ False 2))) (NamedOperator "+") + (Literal (IntegerLiteral _ False 1))))) (NamedOperator "||") + (Literal (BoolLiteral _ True))) -> True + _ -> False), + + -- This expression isn't really valid, but it ensures that the first ! is + -- applied only to x and not x*!y. + checkParsesAs "!x * !y + !z" + (\e -> case e of + (InfixExpression _ + (InfixExpression _ + (UnaryExpression _ (NamedOperator "!") + (Expression _ (NamedVariable (OutputValue _ (VariableName "x"))) [])) (NamedOperator "*") + (UnaryExpression _ (NamedOperator "!") + (Expression _ (NamedVariable (OutputValue _ (VariableName "y"))) []))) (NamedOperator "+") + (UnaryExpression _ (NamedOperator "!") + (Expression _ (NamedVariable (OutputValue _ (VariableName "z"))) []))) -> True + _ -> False), + + checkParsesAs "1 `Int$lessThan` 2" + (\e -> case e of + (InfixExpression _ + (Literal (IntegerLiteral _ False 1)) + (FunctionOperator _ ( + FunctionSpec _ + (TypeFunction _ (JustTypeInstance (TypeInstance BuiltinInt (Positional [])))) + (FunctionName "lessThan") (Positional []))) + (Literal (IntegerLiteral _ False 2))) -> True + _ -> False), + + checkParsesAs "1 `Something$$foo` 2" + (\e -> case e of + (InfixExpression _ + (Literal (IntegerLiteral _ False 1)) + (FunctionOperator _ + (FunctionSpec _ + (CategoryFunction _ (CategoryName "Something")) + (FunctionName "foo") (Positional []))) + (Literal (IntegerLiteral _ False 2))) -> True + _ -> False), + + checkParsesAs "1 `something.foo` 2" + (\e -> case e of + (InfixExpression _ + (Literal (IntegerLiteral _ False 1)) + (FunctionOperator _ + (FunctionSpec _ + (ValueFunction _ + (Expression _ (NamedVariable (OutputValue _ (VariableName "something"))) [])) + (FunctionName "foo") (Positional []))) + (Literal (IntegerLiteral _ False 2))) -> True + _ -> False), + + checkParsesAs "1 `require(x).foo` 2" + (\e -> case e of + InfixExpression _ + (Literal (IntegerLiteral _ False 1)) + (FunctionOperator _ + (FunctionSpec _ + (ValueFunction _ + (Expression _ (BuiltinCall _ (FunctionCall _ BuiltinRequire (Positional []) + (Positional [Expression _ (NamedVariable (OutputValue _ (VariableName "x"))) []]))) [])) + (FunctionName "foo") (Positional []))) + (Literal (IntegerLiteral _ False 2)) -> True + _ -> False), + + checkParsesAs "1 `foo` 2" + (\e -> case e of + (InfixExpression _ + (Literal (IntegerLiteral _ False 1)) + (FunctionOperator _ + (FunctionSpec _ UnqualifiedFunction (FunctionName "foo") (Positional []))) + (Literal (IntegerLiteral _ False 2))) -> True + _ -> False), + + checkParsesAs "`Bits$not` 2" + (\e -> case e of + (UnaryExpression _ + (FunctionOperator _ ( + FunctionSpec _ + (TypeFunction _ (JustTypeInstance (TypeInstance (CategoryName "Bits") (Positional [])))) + (FunctionName "not") (Positional []))) + (Literal (IntegerLiteral _ False 2))) -> True + _ -> False), + + checkParsesAs "`Bits$$not` 2" + (\e -> case e of + (UnaryExpression _ + (FunctionOperator _ + (FunctionSpec _ + (CategoryFunction _ (CategoryName "Bits")) + (FunctionName "not") (Positional []))) + (Literal (IntegerLiteral _ False 2))) -> True + _ -> False), + + checkParsesAs "`bits.not` 2" + (\e -> case e of + (UnaryExpression _ + (FunctionOperator _ + (FunctionSpec _ + (ValueFunction _ + (Expression _ (NamedVariable (OutputValue _ (VariableName "bits"))) [])) + (FunctionName "not") (Positional []))) + (Literal (IntegerLiteral _ False 2))) -> True + _ -> False), + + checkParsesAs "`require(x).not` 2" + (\e -> case e of + UnaryExpression _ + (FunctionOperator _ + (FunctionSpec _ + (ValueFunction _ + (Expression _ (BuiltinCall _ (FunctionCall _ BuiltinRequire (Positional []) + (Positional [Expression _ (NamedVariable (OutputValue _ (VariableName "x"))) []]))) [])) + (FunctionName "not") (Positional []))) + (Literal (IntegerLiteral _ False 2)) -> True + _ -> False), + + checkParsesAs "`not` 2" + (\e -> case e of + (UnaryExpression _ + (FunctionOperator _ + (FunctionSpec _ UnqualifiedFunction (FunctionName "not") (Positional []))) + (Literal (IntegerLiteral _ False 2))) -> True + _ -> False), + + checkParsesAs "\\b10" (\e -> case e of + (Literal (IntegerLiteral _ True 2)) -> True + _ -> False), + + checkParsesAs "\\B10" (\e -> case e of + (Literal (IntegerLiteral _ True 2)) -> True + _ -> False), + + checkParsesAs "\\o10" (\e -> case e of + (Literal (IntegerLiteral _ True 8)) -> True + _ -> False), + + checkParsesAs "\\O10" (\e -> case e of + (Literal (IntegerLiteral _ True 8)) -> True + _ -> False), + + checkParsesAs "\\d10" (\e -> case e of + (Literal (IntegerLiteral _ True 10)) -> True + _ -> False), + + checkParsesAs "\\D10" (\e -> case e of + (Literal (IntegerLiteral _ True 10)) -> True + _ -> False), + + checkParsesAs "\\x10" (\e -> case e of + (Literal (IntegerLiteral _ True 16)) -> True + _ -> False), + + checkParsesAs "\\X10" (\e -> case e of + (Literal (IntegerLiteral _ True 16)) -> True + _ -> False), + + checkParsesAs "10" (\e -> case e of + (Literal (IntegerLiteral _ False 10)) -> True + _ -> False), + + checkParsesAs "1.2345" (\e -> case e of + (Literal (DecimalLiteral _ 12345 (-4))) -> True + _ -> False), + + checkParsesAs "1.2345E+4" (\e -> case e of + (Literal (DecimalLiteral _ 12345 0)) -> True + _ -> False), + + checkParsesAs "1.2345E-4" (\e -> case e of + (Literal (DecimalLiteral _ 12345 (-8))) -> True + _ -> False) + ] + +checkParseSuccess f = do + contents <- loadFile f + let parsed = readMulti f contents :: CompileInfo [ExecutableProcedure SourcePos] + return $ check parsed + where + check c + | isCompileError c = compileError $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c) + | otherwise = return () + +checkParseFail f = do + contents <- loadFile f + let parsed = readMulti f contents :: CompileInfo [ExecutableProcedure SourcePos] + return $ check parsed + where + check c + | isCompileError c = return () + | otherwise = compileError $ "Parse " ++ f ++ ": Expected failure but got\n" ++ + show (getCompileSuccess c) ++ "\n" + +checkShortParseSuccess s = do + let parsed = readSingle "(string)" s :: CompileInfo (Statement SourcePos) + return $ check parsed + where + check c + | isCompileError c = compileError $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c) + | otherwise = return () + +checkShortParseFail s = do + let parsed = readSingle "(string)" s :: CompileInfo (Statement SourcePos) + return $ check parsed + where + check c + | isCompileError c = return () + | otherwise = compileError $ "Parse '" ++ s ++ "': Expected failure but got\n" ++ + show (getCompileSuccess c) ++ "\n" + +checkParsesAs s m = return $ do + let parsed = readSingle "(string)" s :: CompileInfo (Expression SourcePos) + check parsed + e <- parsed + when (not $ m e) $ + compileError $ "No match in '" ++ s ++ "':\n" ++ show e + where + check c + | isCompileError c = compileError $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c) + | otherwise = return () diff --git a/src/Test/TypeCategory.hs b/src/Test/TypeCategory.hs new file mode 100644 --- /dev/null +++ b/src/Test/TypeCategory.hs @@ -0,0 +1,942 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Test.TypeCategory (tests) where + +import Control.Arrow +import Control.Monad +import Data.List +import System.FilePath +import System.IO +import Text.Parsec +import Text.Parsec.String +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Base.CompileError +import Base.Mergeable +import Compilation.CompileInfo +import Parser.Common +import Parser.TypeCategory +import Test.Common +import Types.Builtin +import Types.Positional +import Types.TypeCategory +import Types.TypeInstance +import Types.Variance + + +tests :: [IO (CompileInfo ())] +tests = [ + checkSingleParseSuccess ("testfiles" "value_interface.0rx"), + checkSingleParseSuccess ("testfiles" "type_interface.0rx"), + checkSingleParseSuccess ("testfiles" "concrete.0rx"), + + checkShortParseSuccess "concrete Type<#x> {}", + checkShortParseSuccess "concrete Type {}", + checkShortParseFail "concrete Type {}", + checkShortParseFail "concrete Type {}", + checkShortParseFail "concrete Type {}", + checkShortParseFail "concrete Type> {}", + checkShortParseSuccess "concrete Type { refines T }", + checkShortParseFail "concrete Type { refines #x }", + checkShortParseSuccess "concrete Type { defines T }", + checkShortParseFail "concrete Type { defines #x }", + checkShortParseFail "concrete Type { refines optional }", + checkShortParseFail "concrete Type { refines optional T }", + checkShortParseSuccess "concrete Type<#x|#y> { #x requires #y }", + checkShortParseSuccess "concrete Type<#x|#y> { #x allows #y }", + checkShortParseSuccess "concrete Type<#x|#y> { #x defines T }", + checkShortParseFail "concrete Type<#x|#y> { #x defines #y }", + + checkShortParseSuccess "@type interface Type<#x> {}", + checkShortParseSuccess "@type interface Type {}", + checkShortParseFail "@type interface Type { refines T }", + checkShortParseFail "@type interface Type { defines T }", + checkShortParseSuccess "@type interface Type<#x> { #x allows T }", + + checkShortParseSuccess "@value interface Type<#x> {}", + checkShortParseSuccess "@value interface Type {}", + checkShortParseSuccess "@value interface Type { refines T }", + checkShortParseFail "@value interface Type { defines T }", + checkShortParseSuccess "@value interface Type<#x> { #x allows T }", + + checkOperationSuccess ("testfiles" "value_refines_value.0rx") (checkConnectedTypes defaultCategories), + checkOperationFail ("testfiles" "value_refines_instance.0rx") (checkConnectedTypes defaultCategories), + checkOperationFail ("testfiles" "value_refines_concrete.0rx") (checkConnectedTypes defaultCategories), + + checkOperationSuccess ("testfiles" "concrete_refines_value.0rx") (checkConnectedTypes defaultCategories), + checkOperationFail ("testfiles" "concrete_refines_instance.0rx") (checkConnectedTypes defaultCategories), + checkOperationFail ("testfiles" "concrete_refines_concrete.0rx") (checkConnectedTypes defaultCategories), + checkOperationSuccess ("testfiles" "concrete_defines_instance.0rx") (checkConnectedTypes defaultCategories), + checkOperationFail ("testfiles" "concrete_defines_value.0rx") (checkConnectedTypes defaultCategories), + checkOperationFail ("testfiles" "concrete_defines_concrete.0rx") (checkConnectedTypes defaultCategories), + + checkOperationSuccess + ("testfiles" "concrete_refines_value.0rx") + (checkConnectedTypes $ Map.fromList [ + (CategoryName "Parent2",InstanceInterface [] NoNamespace (CategoryName "Parent2") [] [] []) + ]), + checkOperationFail + ("testfiles" "concrete_refines_value.0rx") + (checkConnectedTypes $ Map.fromList [ + (CategoryName "Parent",InstanceInterface [] NoNamespace (CategoryName "Parent") [] [] []) + ]), + + checkOperationSuccess + ("testfiles" "partial.0rx") + (checkConnectedTypes $ Map.fromList [ + (CategoryName "Parent",ValueInterface [] NoNamespace (CategoryName "Parent") [] [] [] []) + ]), + checkOperationFail + ("testfiles" "partial.0rx") + (checkConnectedTypes $ Map.fromList [ + (CategoryName "Parent",InstanceInterface [] NoNamespace (CategoryName "Parent") [] [] []) + ]), + checkOperationFail + ("testfiles" "partial.0rx") + (checkConnectedTypes $ Map.fromList [ + (CategoryName "Parent",ValueConcrete [] NoNamespace (CategoryName "Parent") [] [] [] [] []) + ]), + + checkOperationSuccess ("testfiles" "value_refines_value.0rx") (checkConnectionCycles Map.empty), + checkOperationSuccess ("testfiles" "concrete_refines_value.0rx") (checkConnectionCycles Map.empty), + checkOperationSuccess ("testfiles" "concrete_defines_instance.0rx") (checkConnectionCycles Map.empty), + checkOperationFail ("testfiles" "value_cycle.0rx") (checkConnectionCycles Map.empty), + + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + map (show . getCategoryName) ts `containsPaired` [ + "Type","Object2","Object3","Object1","Parent","Child" + ]), + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts), + + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + scrapeAllRefines ts `containsExactly` [ + ("Object1","Object3<#y>"), + ("Object1","Object2"), + ("Object3","Object2"), + ("Parent","Object1<#x,Object3>"), + ("Parent","Object3>"), + ("Parent","Object2"), + ("Child","Parent"), + ("Child","Object1>"), + ("Child","Object3>"), + ("Child","Object2") + ] + scrapeAllDefines ts `containsExactly` [ + ("Child","Type") + ]), + + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + existing <- return $ Map.fromList [ + (CategoryName "Parent2",InstanceInterface [] NoNamespace (CategoryName "Parent2") [] [] []) + ] + ts <- topoSortCategories existing ts + flattenAllConnections existing ts), + checkOperationFail + ("testfiles" "flatten.0rx") + (\ts -> do + existing <- return $ Map.fromList [ + (CategoryName "Parent",InstanceInterface [] NoNamespace (CategoryName "Parent") [] [] []) + ] + topoSortCategories existing ts), + + checkOperationSuccess + ("testfiles" "partial.0rx") + (\ts -> do + existing <- return $ Map.fromList [ + (CategoryName "Parent", + ValueInterface [] NoNamespace (CategoryName "Parent") [] + [ValueRefine [] $ TypeInstance (CategoryName "Object1") (Positional []), + ValueRefine [] $ TypeInstance (CategoryName "Object2") (Positional [])] [] []), + -- NOTE: Object1 deliberately excluded here so that we catch + -- unnecessary recursion in existing categories. + (CategoryName "Object2", + ValueInterface [] NoNamespace (CategoryName "Object2") [] [] [] []) + ] + ts <- topoSortCategories existing ts + ts <- flattenAllConnections existing ts + scrapeAllRefines ts `containsExactly` [ + ("Child","Parent"), + ("Child","Object1"), + ("Child","Object2") + ]), + + checkOperationSuccess ("testfiles" "valid_variances.0rx") (checkParamVariances defaultCategories), + checkOperationFail ("testfiles" "contravariant_refines_covariant.0rx") (checkParamVariances defaultCategories), + checkOperationFail ("testfiles" "contravariant_refines_invariant.0rx") (checkParamVariances defaultCategories), + checkOperationFail ("testfiles" "covariant_refines_contravariant.0rx") (checkParamVariances defaultCategories), + checkOperationFail ("testfiles" "covariant_refines_invariant.0rx") (checkParamVariances defaultCategories), + checkOperationFail ("testfiles" "contravariant_defines_covariant.0rx") (checkParamVariances defaultCategories), + checkOperationFail ("testfiles" "contravariant_defines_invariant.0rx") (checkParamVariances defaultCategories), + checkOperationFail ("testfiles" "covariant_defines_contravariant.0rx") (checkParamVariances defaultCategories), + checkOperationFail ("testfiles" "covariant_defines_invariant.0rx") (checkParamVariances defaultCategories), + checkOperationFail ("testfiles" "concrete_duplicate_param.0rx") (checkParamVariances defaultCategories), + checkOperationFail ("testfiles" "type_duplicate_param.0rx") (checkParamVariances defaultCategories), + checkOperationFail ("testfiles" "value_duplicate_param.0rx") (checkParamVariances defaultCategories), + + checkOperationSuccess + ("testfiles" "concrete_refines_value.0rx") + (checkParamVariances $ Map.fromList [ + (CategoryName "Parent2",InstanceInterface [] NoNamespace (CategoryName "Parent2") [] [] []) + ]), + checkOperationFail + ("testfiles" "concrete_refines_value.0rx") + (checkParamVariances $ Map.fromList [ + (CategoryName "Parent",InstanceInterface [] NoNamespace (CategoryName "Parent") [] [] []) + ]), + + checkOperationSuccess + ("testfiles" "partial_params.0rx") + (checkParamVariances $ Map.fromList [ + (CategoryName "Parent", + ValueInterface [] NoNamespace (CategoryName "Parent") + [ValueParam [] (ParamName "#w") Contravariant, + ValueParam [] (ParamName "#z") Covariant] [] [] []) + ]), + checkOperationFail + ("testfiles" "partial_params.0rx") + (checkParamVariances $ Map.fromList [ + (CategoryName "Parent", + ValueInterface [] NoNamespace (CategoryName "Parent") + [ValueParam [] (ParamName "#w") Invariant, + ValueParam [] (ParamName "#z") Covariant] [] [] []) + ]), + checkOperationFail + ("testfiles" "partial_params.0rx") + (checkParamVariances $ Map.fromList [ + (CategoryName "Parent", + ValueInterface [] NoNamespace (CategoryName "Parent") + [ValueParam [] (ParamName "#w") Contravariant, + ValueParam [] (ParamName "#z") Invariant] [] [] []) + ]), + + checkOperationSuccess + ("testfiles" "concrete.0rx") + (\ts -> do + rs <- getTypeRefines ts "Type<#a,#b,#c,#d,#e,#f>" "Type" + rs `containsPaired` ["#a","#b","#c","#d","#e","#f"] + ), + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + rs <- getTypeRefines ts "Object1<#a,#b>" "Object1" + rs `containsPaired` ["#a","#b"]), + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + rs <- getTypeRefines ts "Object1<#a,#b>" "Object3" + rs `containsPaired` ["#b"]), + checkOperationFail + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + rs <- getTypeRefines ts "Undefined<#a,#b>" "Undefined" + rs `containsPaired` ["#a","#b"]), + checkOperationFail + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + rs <- getTypeRefines ts "Object1<#a>" "Object1" + rs `containsPaired` ["#a"]), + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + rs <- getTypeRefines ts "Parent<#t>" "Object1" + rs `containsPaired` ["#t","Object3"]), + checkOperationFail + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + getTypeRefines ts "Parent<#t>" "Child"), + checkOperationFail + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + getTypeRefines ts "Child" "Type"), + checkOperationFail + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + getTypeRefines ts "Child" "Missing"), + + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + rs <- getTypeDefines ts "Child" "Type" + rs `containsPaired` ["Child"]), + checkOperationFail + ("testfiles" "flatten.0rx") + (\ts -> do + getTypeDefines ts "Child" "Parent"), + checkOperationFail + ("testfiles" "flatten.0rx") + (\ts -> do + getTypeDefines ts "Child" "Missing"), + + checkOperationSuccess + ("testfiles" "concrete.0rx") + (\ts -> do + vs <- getTypeVariance ts "Type" + vs `containsPaired` [Contravariant,Contravariant, + Invariant,Invariant, + Covariant,Covariant]), + checkOperationFail + ("testfiles" "flatten.0rx") + (\ts -> do + getTypeVariance ts "Missing"), + + checkOperationSuccess + ("testfiles" "concrete.0rx") + (\ts -> do + rs <- getTypeFilters ts "Type<#a,#b,#c,#d,#e,#f>" + checkPaired containsExactly rs [ + ["allows Parent"], + ["requires Type2<#a>"], + ["defines Equals<#c>"], + [], + [], + [] + ]), + checkOperationSuccess + ("testfiles" "concrete.0rx") + (\ts -> do + rs <- getTypeFilters ts "Type,#b,Type3<#x>,#d,#e,#f>" + checkPaired containsExactly rs [ + ["allows Parent"], + ["requires Type2>"], + ["defines Equals>"], + [], + [], + [] + ]), + + checkOperationSuccess + ("testfiles" "value_interface.0rx") + (\ts -> do + rs <- getTypeFilters ts "Type<#a,#b,#c,#d,#e,#f>" + checkPaired containsExactly rs [ + ["allows Parent"], + ["requires Type2<#a>"], + ["defines Equals<#c>"], + [], + [], + [] + ]), + checkOperationSuccess + ("testfiles" "value_interface.0rx") + (\ts -> do + rs <- getTypeFilters ts "Type,#b,Type3<#x>,#d,#e,#f>" + checkPaired containsExactly rs [ + ["allows Parent"], + ["requires Type2>"], + ["defines Equals>"], + [], + [], + [] + ]), + + checkOperationSuccess + ("testfiles" "type_interface.0rx") + (\ts -> do + rs <- getTypeDefinesFilters ts "Type<#a,#b,#c,#d,#e,#f>" + checkPaired containsExactly rs [ + ["allows Parent"], + ["requires Type2<#a>"], + ["defines Equals<#c>"], + [], + [], + [] + ]), + checkOperationSuccess + ("testfiles" "type_interface.0rx") + (\ts -> do + rs <- getTypeDefinesFilters ts "Type,#b,Type3<#x>,#d,#e,#f>" + checkPaired containsExactly rs [ + ["allows Parent"], + ["requires Type2>"], + ["defines Equals>"], + [], + [], + [] + ]), + + -- TODO: Clean these tests up. + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories + let r = CategoryResolver ta + checkTypeSuccess r [] "Child"), + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories + let r = CategoryResolver ta + checkTypeSuccess r [] "[Child|Child]"), + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories + let r = CategoryResolver ta + checkTypeSuccess r [] "[Child&Child]"), + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories + let r = CategoryResolver ta + checkTypeSuccess r [] "Object2"), + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories + let r = CategoryResolver ta + checkTypeSuccess r [] "[Object2|Object2]"), + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories + let r = CategoryResolver ta + checkTypeSuccess r [] "[Object2&Object2]"), + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories + let r = CategoryResolver ta + checkTypeFail r [] "Type"), + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories + let r = CategoryResolver ta + checkTypeFail r [] "[Type|Type]"), + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories + let r = CategoryResolver ta + checkTypeFail r [] "[Type&Type]"), + + -- TODO: Clean these tests up. + checkOperationSuccess + ("testfiles" "filters.0rx") + (\ts -> do + ts <- topoSortCategories Map.empty ts + ta <- flattenAllConnections Map.empty ts >>= declareAllTypes Map.empty + let r = CategoryResolver ta + checkTypeSuccess r [] "Value0"), + checkOperationFail + ("testfiles" "filters.0rx") + (\ts -> do + ts <- topoSortCategories Map.empty ts + ta <- flattenAllConnections Map.empty ts >>= declareAllTypes Map.empty + let r = CategoryResolver ta + checkTypeSuccess r [] "Value0"), + checkOperationSuccess + ("testfiles" "filters.0rx") + (\ts -> do + ts <- topoSortCategories Map.empty ts + ta <- flattenAllConnections Map.empty ts >>= declareAllTypes Map.empty + let r = CategoryResolver ta + checkTypeSuccess r [] "Value0"), + checkOperationFail + ("testfiles" "filters.0rx") + (\ts -> do + ts <- topoSortCategories Map.empty ts + ta <- flattenAllConnections Map.empty ts >>= declareAllTypes Map.empty + let r = CategoryResolver ta + checkTypeSuccess r + [("#x",[]),("#y",[])] + "Value0<#x,#y>"), + checkOperationSuccess + ("testfiles" "filters.0rx") + (\ts -> do + ts <- topoSortCategories Map.empty ts + ta <- flattenAllConnections Map.empty ts >>= declareAllTypes Map.empty + let r = CategoryResolver ta + checkTypeSuccess r + [("#x",["allows #y","requires Function<#x,#y>"]), + ("#y",["requires #x","defines Equals<#y>"])] + "Value0<#x,#y>"), + checkOperationSuccess + ("testfiles" "filters.0rx") + (\ts -> do + ts <- topoSortCategories Map.empty ts + ta <- flattenAllConnections Map.empty ts >>= declareAllTypes Map.empty + let r = CategoryResolver ta + checkTypeSuccess r + [("#x",["allows Value2","requires Function<#x,Value2>"])] + "Value0<#x,Value2>"), + checkOperationFail + ("testfiles" "filters.0rx") + (\ts -> do + ts <- topoSortCategories Map.empty ts + ta <- flattenAllConnections Map.empty ts >>= declareAllTypes Map.empty + let r = CategoryResolver ta + checkTypeSuccess r + [("#x",["allows Value2","requires Function<#x,Value2>"]), + ("#y",["requires #x","defines Equals<#y>"])] + "Value0<#x,#y>"), + + checkOperationSuccess + ("testfiles" "concrete_instances.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "concrete_missing_define.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "concrete_missing_refine.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + checkCategoryInstances defaultCategories ts), + checkOperationSuccess + ("testfiles" "value_instances.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "value_missing_define.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "value_missing_refine.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + checkCategoryInstances defaultCategories ts), + checkOperationSuccess + ("testfiles" "type_instances.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "type_missing_define.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "type_missing_refine.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + checkCategoryInstances defaultCategories ts), + checkOperationSuccess + ("testfiles" "requires_concrete.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + checkCategoryInstances defaultCategories ts), + + -- TODO: Clean these tests up. + checkOperationSuccess + ("testfiles" "merged.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + ts <- flattenAllConnections defaultCategories ts + tm <- declareAllTypes defaultCategories ts + rs <- getRefines tm "Test" + rs `containsExactly` ["Value0","Value1","Value2","Value3", + "Value4","Inherit1","Inherit2"]), + + checkOperationSuccess + ("testfiles" "merged.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()), + checkOperationSuccess + ("testfiles" "duplicate_refine.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()), + checkOperationSuccess + ("testfiles" "duplicate_define.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()), + checkOperationFail + ("testfiles" "refine_wrong_direction.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()), + checkOperationFail + ("testfiles" "inherit_incompatible.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()), + checkOperationSuccess + ("testfiles" "merge_incompatible.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()), + + checkOperationSuccess + ("testfiles" "flatten.0rx") + (\ts -> do + let tm0 = Map.fromList [ + (CategoryName "Parent2",InstanceInterface [] NoNamespace (CategoryName "Parent2") [] [] []) + ] + tm <- includeNewTypes tm0 ts + rs <- getRefines tm "Child" + rs `containsExactly` ["Parent","Object2", + "Object1>", + "Object3>"]), + + checkOperationSuccess + ("testfiles" "category_function_param_match.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "function_param_clash.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "function_duplicate_param.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "function_bad_filter_param.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "function_bad_allows_type.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "function_bad_allows_variance.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "function_bad_requires_type.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "function_bad_requires_variance.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "function_bad_defines_type.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "function_bad_defines_variance.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "function_bad_arg.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "function_bad_return.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "weak_arg.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "weak_return.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + + checkOperationSuccess + ("testfiles" "function_filters_satisfied.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "function_requires_missed.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "function_allows_missed.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "function_defines_missed.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + + checkOperationSuccess + ("testfiles" "valid_function_variance.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "bad_value_arg_variance.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "bad_value_return_variance.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "bad_type_arg_variance.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + checkOperationFail + ("testfiles" "bad_type_return_variance.0rx") + (\ts -> checkCategoryInstances defaultCategories ts), + + checkOperationSuccess + ("testfiles" "valid_filter_variance.0rx") + (\ts -> checkParamVariances defaultCategories ts), + checkOperationFail + ("testfiles" "bad_allows_variance_right.0rx") + (\ts -> checkParamVariances defaultCategories ts), + checkOperationFail + ("testfiles" "bad_defines_variance_right.0rx") + (\ts -> checkParamVariances defaultCategories ts), + checkOperationFail + ("testfiles" "bad_requires_variance_right.0rx") + (\ts -> checkParamVariances defaultCategories ts), + checkOperationFail + ("testfiles" "bad_allows_variance_left.0rx") + (\ts -> checkParamVariances defaultCategories ts), + checkOperationFail + ("testfiles" "bad_defines_variance_left.0rx") + (\ts -> checkParamVariances defaultCategories ts), + checkOperationFail + ("testfiles" "bad_requires_variance_left.0rx") + (\ts -> checkParamVariances defaultCategories ts), + + checkOperationFail + ("testfiles" "conflicting_declaration.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()), + checkOperationFail + ("testfiles" "conflicting_inherited.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()), + checkOperationSuccess + ("testfiles" "successful_merge.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()), + checkOperationSuccess + ("testfiles" "merge_with_refine.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()), + checkOperationFail + ("testfiles" "failed_merge.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()), + checkOperationFail + ("testfiles" "ambiguous_merge_inherit.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()), + checkOperationFail + ("testfiles" "merge_different_scopes.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()), + + checkOperationSuccess + ("testfiles" "successful_merge_params.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()), + checkOperationFail + ("testfiles" "failed_merge_params.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()), + checkOperationSuccess + ("testfiles" "preserve_merged.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()), + checkOperationFail + ("testfiles" "conflict_in_preserved.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()), + checkOperationSuccess + ("testfiles" "resolved_in_preserved.0rx") + (\ts -> do + ts <- topoSortCategories defaultCategories ts + flattenAllConnections defaultCategories ts + return ()) + ] + + +getRefines tm n = + case (CategoryName n) `Map.lookup` tm of + (Just t) -> return $ map (show . vrType) (getCategoryRefines t) + _ -> compileError $ "Type " ++ n ++ " not found" + +getDefines tm n = + case (CategoryName n) `Map.lookup` tm of + (Just t) -> return $ map (show . vdType) (getCategoryDefines t) + _ -> compileError $ "Type " ++ n ++ " not found" + +getTypeRefines ts s n = do + ta <- declareAllTypes defaultCategories ts + let r = CategoryResolver ta + t <- readSingle "(string)" s + Positional rs <- trRefines r t (CategoryName n) + return $ map show rs + +getTypeDefines ts s n = do + ta <- declareAllTypes defaultCategories ts + let r = CategoryResolver ta + t <- readSingle "(string)" s + Positional ds <- trDefines r t (CategoryName n) + return $ map show ds + +getTypeVariance ts n = do + ta <- declareAllTypes defaultCategories ts + let r = CategoryResolver ta + (Positional vs) <- trVariance r (CategoryName n) + return vs + +getTypeFilters ts s = do + ta <- declareAllTypes defaultCategories ts + let r = CategoryResolver ta + t <- readSingle "(string)" s + Positional vs <- trTypeFilters r t + return $ map (map show) vs + +getTypeDefinesFilters ts s = do + ta <- declareAllTypes defaultCategories ts + let r = CategoryResolver ta + t <- readSingle "(string)" s + Positional vs <- trDefinesFilters r t + return $ map (map show) vs + +scrapeAllRefines = map (show *** show) . concat . map scrapeSingle where + scrapeSingle (ValueInterface _ _ n _ rs _ _) = map ((,) n . vrType) rs + scrapeSingle (ValueConcrete _ _ n _ rs _ _ _) = map ((,) n . vrType) rs + scrapeSingle _ = [] + +scrapeAllDefines = map (show *** show) . concat . map scrapeSingle where + scrapeSingle (ValueConcrete _ _ n _ _ ds _ _) = map ((,) n . vdType) ds + scrapeSingle _ = [] + +checkPaired :: (Show a, CompileErrorM m, MergeableM m) => + (a -> a -> m ()) -> [a] -> [a] -> m () +checkPaired f actual expected + | length actual /= length expected = + compileError $ "Different item counts: " ++ show actual ++ " (actual) vs. " ++ + show expected ++ " (expected)" + | otherwise = mergeAllM $ map check (zip3 actual expected [1..]) where + check (a,e,n) = f a e `reviseError` ("Item " ++ show n ++ " mismatch") + +containsPaired :: (Eq a, Show a, CompileErrorM m, MergeableM m) => + [a] -> [a] -> m () +containsPaired = checkPaired checkSingle where + checkSingle a e + | a == e = return () + | otherwise = compileError $ show a ++ " (actual) vs. " ++ show e ++ " (expected)" + +checkOperationSuccess f o = do + contents <- loadFile f + let parsed = readMulti f contents :: CompileInfo [AnyCategory SourcePos] + return $ check (parsed >>= o >> return ()) + where + check = flip reviseError ("Check " ++ f ++ ":") + +checkOperationFail f o = do + contents <- loadFile f + let parsed = readMulti f contents :: CompileInfo [AnyCategory SourcePos] + return $ check (parsed >>= o >> return ()) + where + check c + | isCompileError c = return () + | otherwise = compileError $ "Check " ++ f ++ ": Expected failure but got\n" ++ + show (getCompileSuccess c) ++ "\n" + +checkSingleParseSuccess f = do + contents <- loadFile f + let parsed = readSingle f contents :: CompileInfo (AnyCategory SourcePos) + return $ check parsed + where + check c + | isCompileError c = compileError $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c) + | otherwise = return () + +checkSingleParseFail f = do + contents <- loadFile f + let parsed = readSingle f contents :: CompileInfo (AnyCategory SourcePos) + return $ check parsed + where + check c + | isCompileError c = return () + | otherwise = compileError $ "Parse " ++ f ++ ": Expected failure but got\n" ++ + show (getCompileSuccess c) ++ "\n" + +checkShortParseSuccess s = do + let parsed = readSingle "(string)" s :: CompileInfo (AnyCategory SourcePos) + return $ check parsed + where + check c + | isCompileError c = compileError $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c) + | otherwise = return () + +checkShortParseFail s = do + let parsed = readSingle "(string)" s :: CompileInfo (AnyCategory SourcePos) + return $ check parsed + where + check c + | isCompileError c = return () + | otherwise = compileError $ "Parse '" ++ s ++ "': Expected failure but got\n" ++ + show (getCompileSuccess c) ++ "\n" diff --git a/src/Test/TypeInstance.hs b/src/Test/TypeInstance.hs new file mode 100644 --- /dev/null +++ b/src/Test/TypeInstance.hs @@ -0,0 +1,722 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Test.TypeInstance (tests) where + +import Data.List +import Text.Parsec +import qualified Data.Map as Map + +import Base.CompileError +import Compilation.CompileInfo +import Parser.Common +import Parser.TypeInstance +import Test.Common +import Types.Positional +import Types.TypeInstance +import Types.Variance + + +tests :: [IO (CompileInfo ())] +tests = [ + checkSimpleConvertSuccess + "Type0" + "Type0", + checkSimpleConvertSuccess + "Type3" + "Type0", + checkSimpleConvertFail + "Type0" + "Type3", + checkSimpleConvertSuccess + "Type1" + "Type0", + checkSimpleConvertFail + "Type0" + "Type1", + checkSimpleConvertSuccess + "Type2" + "Type2", + checkSimpleConvertSuccess + "Type2" + "Type2", + checkSimpleConvertFail + "Type2" + "Type2", + checkSimpleConvertFail + "Type2" + "Type2", + checkSimpleConvertFail + "Type2" + "Type2", + checkSimpleConvertFail + "Type2" + "Type2", + checkSimpleConvertSuccess + "Type3" + "[Type0|Type3]", + checkSimpleConvertSuccess + "Type3" + "[Type0|Type1]", + checkSimpleConvertSuccess + "[Type3|Type1]" + "Type0", + checkSimpleConvertSuccess + "[Type0&Type3]" + "Type3", + checkSimpleConvertSuccess + "[Type3|Type3]" + "Type3", + checkSimpleConvertSuccess + "[Type1&Type3]" + "[Type1|Type3]", + checkSimpleConvertFail + "[Type0|Type3]" + "Type3", + checkSimpleConvertFail + "Type0" + "[Type0&Type3]", + checkSimpleConvertFail + "[Type0|Type3]" + "[Type0&Type3]", + + checkSimpleConvertSuccess + "any" + "any", + checkSimpleConvertSuccess + "Type0" + "any", + checkSimpleConvertFail + "any" + "Type0", + checkSimpleConvertSuccess + "all" + "all", + checkSimpleConvertFail + "Type0" + "all", + checkSimpleConvertSuccess + "all" + "Type0", + checkSimpleConvertSuccess + "all" + "any", + checkSimpleConvertFail + "any" + "all", + checkSimpleConvertFail + "Type1" + "Type1", + checkSimpleConvertFail + "Type1" + "Type1", + + checkConvertSuccess + [("#x",[])] + "#x" "#x", + checkConvertFail + [("#x",[]), + ("#y",[])] + "#x" "#y", + checkConvertSuccess + [("#x",["requires #y"]), + ("#y",["allows #x"])] + "#x" "#y", + checkConvertSuccess + [("#x",["requires #y"]), + ("#y",[])] + "#x" "#y", + checkConvertSuccess + [("#x",[]), + ("#y",["allows #x"])] + "#x" "#y", + + -- NOTE: defines are not checked for instance conversions. + checkConvertSuccess + [("#x",["requires #y","defines Instance0"]), + ("#y",["allows #x"])] + "#x" "#y", + checkConvertSuccess + [("#x",["requires #y"]), + ("#y",["allows #x","defines Instance0"])] + "#x" "#y", + checkConvertSuccess + [("#x",["requires #y","defines Instance0"]), + ("#y",["allows #x","defines Instance0"])] + "#x" "#y", + checkConvertFail + [("#x",["defines Instance0"]), + ("#y",["defines Instance0"])] + "#x" "#y", + checkConvertSuccess + [("#x",["requires Type0","defines Instance0"])] + "#x" "Type0", + checkConvertSuccess + [("#x",["allows Type0","defines Instance0"])] + "Type0" "#x", + + checkConvertSuccess + [("#x",["requires #z"]), + ("#y",["allows #z"]), + ("#z",[])] + "#x" "#y", + checkConvertSuccess + [("#x",["requires #z"]), + ("#y",[]), + ("#z",["requires #y"])] + "#x" "#y", + -- NOTE: This is technically valid, but the checking mechanism doesn't do + -- a full graph search, so the writer needs to be explicit about implied + -- additional filters, e.g., "#x requires #y" => "#y allows #x". + checkConvertFail + [("#w",["allows #x"]), + ("#x",[]), + ("#y",[]), + ("#z",["allows #w","requires #y"])] + "#x" "#y", + checkConvertSuccess + [("#x",["requires Type3"]), + ("#y",["allows Type0"])] + "#x" "#y", + checkConvertSuccess + [("#x",["requires #y"]), + ("#y",["requires Type3"])] + "#x" "Type0", + checkConvertSuccess + [("#x",["allows #y"]), + ("#y",["allows Type0"])] + "Type3" "#x", + + checkConvertSuccess + [("#x",[])] + "Type2" "Type2", + checkConvertFail + [("#x",[]), + ("#y",[])] + "Type2" "Type2", + checkConvertSuccess + [("#x",["requires #y"]), + ("#y",["allows #x"])] + "Type2" "Type2", + checkConvertSuccess + [("#x",["requires #y"]), + ("#y",[])] + "Type2" "Type2", + checkConvertSuccess + [("#x",[]), + ("#y",["allows #x"])] + "Type2" "Type2", + + checkConvertSuccess + [("#x",[])] + "Type2<#x,Type0,Type0>" "Type2<#x,Type0,Type0>", + checkConvertFail + [("#x",[]), + ("#y",[])] + "Type2<#x,Type0,Type0>" "Type2<#y,Type0,Type0>", + checkConvertFail + [("#x",["requires #y"]), + ("#y",["allows #x"])] + "Type2<#x,Type0,Type0>" "Type2<#y,Type0,Type0>", + checkConvertFail + [("#x",["requires #y"]), + ("#y",[])] + "Type2<#x,Type0,Type0>" "Type2<#y,Type0,Type0>", + checkConvertFail + [("#x",[]), + ("#y",["allows #x"])] + "Type2<#x,Type0,Type0>" "Type2<#y,Type0,Type0>", + checkConvertSuccess + [("#x",["allows #y"]), + ("#y",["requires #x"])] + "Type2<#x,Type0,Type0>" "Type2<#y,Type0,Type0>", + checkConvertSuccess + [("#x",["allows #y"]), + ("#y",[])] + "Type2<#x,Type0,Type0>" "Type2<#y,Type0,Type0>", + checkConvertSuccess + [("#x",[]), + ("#y",["requires #x"])] + "Type2<#x,Type0,Type0>" "Type2<#y,Type0,Type0>", + + checkConvertFail + [("#x",[])] + "#x" "Type0", + checkConvertSuccess + [("#x",["requires Type0"])] + "#x" "Type0", + checkConvertSuccess + [("#x",["requires Type3"])] + "#x" "Type0", + checkConvertFail + [("#x",[])] + "Type0" "#x", + checkConvertSuccess + [("#x",["allows Type0"])] + "Type0" "#x", + checkConvertSuccess + [("#x",["allows Type0"])] + "Type3" "#x", + + checkConvertFail + [("#x",[])] + "Type2<#x,Type0,Type0>" "Type2", + checkConvertSuccess + [("#x",["allows Type0"])] + "Type2<#x,Type0,Type0>" "Type2", + checkConvertSuccess + [("#x",["allows Type0"])] + "Type2<#x,Type0,Type0>" "Type2", + checkConvertFail + [("#x",[])] + "Type2" "Type2<#x,Type0,Type0>", + checkConvertSuccess + [("#x",["requires Type0"])] + "Type2" "Type2<#x,Type0,Type0>", + checkConvertSuccess + [("#x",["requires Type3"])] + "Type2" "Type2<#x,Type0,Type0>", + + return $ checkTypeSuccess Resolver + [] + "Type4", + return $ checkTypeSuccess Resolver + [("#x",["allows Type0"])] + "Type4<[#x&Type0]>", + return $ checkTypeSuccess Resolver + [("#x",["allows Type0"])] + "Type4<[#x|Type0]>", + return $ checkTypeSuccess Resolver + [("#x",["allows Type0"])] + "Type4<[#x|Type3]>", + return $ checkTypeFail Resolver + [] + "Type5<#x>", + return $ checkTypeSuccess Resolver + [("#x",[])] + "Type5<#x>", + + checkConvertSuccess + [("#x",["requires #y"]), + ("#y",["requires #z"]), + ("#z",[])] + "#x" "#y", + checkConvertSuccess + [("#x",["allows #z"]), + ("#y",["allows #x"]), + ("#z",[])] + "#x" "#y", + + checkSimpleConvertSuccess + "any" + "any", + checkSimpleConvertSuccess + "all" + "all", + checkSimpleConvertSuccess + "all" + "any", + checkConvertSuccess + [("#x",[]), + ("#y",[])] + "[#x&#y]" "[#x&#y]", + checkConvertSuccess + [("#x",[]), + ("#y",[])] + "[#x&#y]" "[#x|#y]", + checkConvertSuccess + [("#x",[]), + ("#y",[])] + "[#x|#y]" "[#x|#y]", + checkConvertSuccess + [("#x",[]), + ("#y",["defines Instance0"])] + "[#x&#y]" "[#x|#y]", + checkConvertSuccess + [("#x",[]), + ("#y",["defines Instance0"])] + "[#x&#y]" "#y", + checkConvertFail + [("#x",[]), + ("#y",["defines Instance0"])] + "[#x|#y]" "#y", + checkConvertSuccess + [("#x",[]), + ("#y",["requires Type3"])] + "[#x&#y]" "[#x|#y]", + checkConvertSuccess + [("#x",[]), + ("#y",["requires Type3"])] + "[#x&#y]" "#y", + checkConvertFail + [("#x",[]), + ("#y",["requires Type3"])] + "[#x|#y]" "#y", + checkConvertSuccess + [("#x",[])] + "all" "#x", + checkConvertSuccess + [("#x",["defines Instance0"])] + "all" "#x", + checkConvertSuccess + [("#x",["requires Type3"])] + "all" "#x", + + checkSimpleConvertSuccess + "optional Type0" + "optional Type0", + checkSimpleConvertSuccess + "weak Type0" + "weak Type0", + checkSimpleConvertSuccess + "Type0" + "optional Type0", + checkSimpleConvertSuccess + "Type0" + "weak Type0", + checkSimpleConvertSuccess + "optional Type0" + "weak Type0", + checkSimpleConvertFail + "optional Type0" + "Type0", + checkSimpleConvertFail + "weak Type0" + "Type0", + checkSimpleConvertFail + "weak Type0" + "optional Type0", + + checkSimpleConvertSuccess + "optional Type3" + "optional Type0", + checkSimpleConvertSuccess + "weak Type3" + "weak Type0", + checkSimpleConvertSuccess + "Type3" + "optional Type0", + checkSimpleConvertSuccess + "Type3" + "weak Type0", + checkSimpleConvertSuccess + "optional Type3" + "weak Type0", + + checkSimpleConvertSuccess + "any" + "optional any", + checkSimpleConvertSuccess + "Type3" + "optional any", + checkSimpleConvertSuccess + "optional all" + "optional Type3", + + return $ checkTypeSuccess Resolver + [("#x",[])] + "#x", + return $ checkTypeFail Resolver + [("#x",[])] + "Type1<#x>", + return $ checkTypeFail Resolver + [("#x",["requires Type3"])] + "Type1<#x>", + return $ checkTypeFail Resolver + [("#x",["defines Instance0"])] + "Type1<#x>", + return $ checkTypeFail Resolver + [] + "Type1", + return $ checkTypeSuccess Resolver + [("#x",["requires Type3","defines Instance0"])] + "Type1<#x>", + return $ checkTypeSuccess Resolver + [] + "Type1", + return $ checkTypeFail Resolver + [] + "Type1>", + return $ checkTypeSuccess Resolver + [] + "Type2", + return $ checkTypeFail Resolver + [] + "Type2", + return $ checkTypeFail Resolver + [] + "Type2", + return $ checkTypeSuccess Resolver + [] + "Type4", + return $ checkTypeFail Resolver + [] + "Type4", + + return $ checkTypeSuccess Resolver + [("#x",["defines Instance1", + "defines Instance1<#x>", + "defines Instance1"])] + "Type2<#x,#x,#x>", + return $ checkTypeFail Resolver + [("#x",["defines Instance1<#x>", + "defines Instance1"])] + "Type2<#x,#x,#x>", + return $ checkTypeFail Resolver + [("#x",["defines Instance1", + "defines Instance1"])] + "Type2<#x,#x,#x>", + return $ checkTypeSuccess Resolver + [("#x",["defines Instance1", + "defines Instance1<#x>"])] + "Type2<#x,#x,#x>", + return $ checkTypeSuccess Resolver + [("#x",["allows Type0", -- Type0 -> #x implies Type3 -> #x + "defines Instance1<#x>"])] + "Type2<#x,#x,#x>", + return $ checkTypeFail Resolver + [("#x",["allows Type3", -- Type3 -> #x doesn't imply Type0 -> #x + "defines Instance1<#x>"])] + "Type2<#x,#x,#x>", + + return $ checkTypeSuccess Resolver + [] + "Type4", + return $ checkTypeFail Resolver + [] + "Type5<#x>", + return $ checkTypeSuccess Resolver + [("#x",[])] + "Type5<#x>", + + return $ checkTypeSuccess Resolver + [] + "[Type4|Type1]", + return $ checkTypeSuccess Resolver + [] + "[Type4&Type1]", + return $ checkTypeSuccess Resolver + [("#x",[])] + "[Type5<#x>|Type1]", + return $ checkTypeSuccess Resolver + [("#x",[])] + "[Type5<#x>&Type1]", + return $ checkTypeSuccess Resolver + [("#x",[])] + "[#x|Type1]", + return $ checkTypeSuccess Resolver + [("#x",[])] + "[#x&Type1]", + return $ checkTypeFail Resolver + [("#x",[])] + "[Type4|Instance0]", + return $ checkTypeFail Resolver + [("#x",[])] + "[Type4&Instance0]", + + return $ checkTypeSuccess Resolver + [] + "[[Type4&Type1]|Type1]", + return $ checkTypeSuccess Resolver + [] + "[[Type4|Type1]&Type1]", + return $ checkTypeSuccess Resolver + [("#x",[])] + "[[Type4&#x]|Type1]", + return $ checkTypeSuccess Resolver + [("#x",[])] + "[[Type4|#x]&Type1]", + + return $ checkTypeFail Resolver + [] + "[Type0]", + + return $ checkDefinesFail Resolver + [("#x",[])] + "Instance1<#x>", + return $ checkDefinesSuccess Resolver + [("#x",["requires Type3"])] + "Instance1<#x>", + return $ checkDefinesFail Resolver + [("#x",["defines Instance1<#x>"])] + "Instance1<#x>", + return $ checkDefinesSuccess Resolver + [] + "Instance1", + return $ checkDefinesSuccess Resolver + [] + "Instance1>" + ] + + +type0 = CategoryName "Type0" +type1 = CategoryName "Type1" +type2 = CategoryName "Type2" +type3 = CategoryName "Type3" +type4 = CategoryName "Type4" +type5 = CategoryName "Type5" +instance0 = CategoryName "Instance0" +instance1 = CategoryName "Instance1" + +variances :: Map.Map CategoryName InstanceVariances +variances = Map.fromList $ [ + (type0,Positional []), -- Type0<> + (type1,Positional [Invariant]), -- Type1 + (type2,Positional [Contravariant,Invariant,Covariant]), -- Type2 + (type3,Positional []), -- Type3<> + (type4,Positional [Invariant]), -- Type4 + (type5,Positional [Invariant]), -- Type5 + (instance0,Positional []), -- Instance0<> + (instance1,Positional [Contravariant]) -- Instance1 + ] + +refines :: Map.Map CategoryName (Map.Map CategoryName (InstanceParams -> InstanceParams)) +refines = Map.fromList $ [ + (type0,Map.fromList $ []), + (type1,Map.fromList $ [ + -- Type1 -> Type0 + (type0,\(Positional [_]) -> + Positional []) + ]), + (type2,Map.fromList $ [ + -- Type2 -> Type0 (inherited from Type1) + (type0,\(Positional [_,_,_]) -> + Positional []), + -- Type2 -> Type1 + (type1,\(Positional [x,_,_]) -> + Positional [x]) + ]), + (type3,Map.fromList $ [ + -- Type3 -> Type0 + (type0,\(Positional []) -> + Positional []) + ]), + (type4,Map.fromList $ []), + (type5,Map.fromList $ []) + ] + +defines :: Map.Map CategoryName (Map.Map CategoryName (InstanceParams -> InstanceParams)) +defines = Map.fromList $ [ + (type0,Map.fromList $ [ + -- Type0 defines Instance1 + (instance1,\(Positional []) -> + Positional [forceParse "Type0"]) + ]), + (type1,Map.fromList $ []), + (type2,Map.fromList $ []), + (type3,Map.fromList $ [ + -- Type3 defines Instance0 + (instance0,\(Positional []) -> + Positional []) + ]), + (type4,Map.fromList $ []), + (type5,Map.fromList $ []) + ] + +typeFilters :: Map.Map CategoryName (InstanceParams -> InstanceFilters) +typeFilters = Map.fromList $ [ + (type0,\(Positional []) -> Positional []), + (type1,\(Positional [_]) -> + Positional [ + -- x requires Type0 + -- x defines Instance0 + [forceParse "requires Type0",forceParse "defines Instance0"] + ]), + (type2,\(Positional [_,y,_]) -> + Positional [ + -- x defines Instance1 + [forceParse $ "defines Instance1"], + -- y defines Instance1 + [forceParse $ "defines Instance1<" ++ show y ++ ">"], + -- z defines Instance1 + [forceParse $ "defines Instance1"] + ]), + (type3,\(Positional []) -> Positional []), + (type4,\(Positional [_]) -> + Positional [ + -- x allows Type0 + [forceParse "allows Type0"] + ]), + (type5,\(Positional [_]) -> Positional [[]]) + ] + +definesFilters :: Map.Map CategoryName (InstanceParams -> InstanceFilters) +definesFilters = Map.fromList $ [ + (instance0,\(Positional []) -> Positional []), + (instance1,\(Positional [_]) -> + Positional [ + -- x requires Type0 + [forceParse "requires Type0"] + ]) + ] + + +checkSimpleConvertSuccess = checkConvertSuccess [] + +checkSimpleConvertFail = checkConvertFail [] + +checkConvertSuccess pa x y = return checked where + prefix = x ++ " -> " ++ y ++ " " ++ showParams pa + checked = do + ([t1,t2],pa2) <- parseTheTest pa [x,y] + check $ checkValueTypeMatch Resolver pa2 t1 t2 + check c + | isCompileError c = compileError $ prefix ++ ":\n" ++ show (getCompileError c) + | otherwise = return () + +checkConvertFail pa x y = return checked where + prefix = x ++ " /> " ++ y ++ " " ++ showParams pa + checked = do + ([t1,t2],pa2) <- parseTheTest pa [x,y] + check $ checkValueTypeMatch Resolver pa2 t1 t2 + check :: CompileInfo a -> CompileInfo () + check c + | isCompileError c = return () + | otherwise = compileError $ prefix ++ ": Expected failure\n" + +data Resolver = Resolver + +instance TypeResolver Resolver where + trRefines _ = getParams refines + trDefines _ = getParams defines + trVariance _ = mapLookup variances + trTypeFilters _ = getTypeFilters + trDefinesFilters _ = getDefinesFilters + -- Type5 is concrete, somewhat arbitrarily. + trConcrete _ = \t -> return (t == type5) + +getParams ma (TypeInstance n1 ps1) n2 = do + ra <- mapLookup ma n1 + f <- mapLookup ra n2 + return $ f ps1 + +getTypeFilters (TypeInstance n ps) = do + f <- mapLookup typeFilters n + return $ f ps + +getDefinesFilters (DefinesInstance n ps) = do + f <- mapLookup definesFilters n + return $ f ps + + +mapLookup :: (Ord n, Show n, CompileErrorM m) => Map.Map n a -> n -> m a +mapLookup ma n = resolve $ n `Map.lookup` ma where + resolve (Just x) = return x + resolve _ = compileError $ "Map key " ++ show n ++ " not found" diff --git a/src/Test/testfiles/ambiguous_merge_inherit.0rx b/src/Test/testfiles/ambiguous_merge_inherit.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/ambiguous_merge_inherit.0rx @@ -0,0 +1,31 @@ +@value interface Type1 {} + +@value interface Type2 { + refines Type1 +} + +@value interface Type3 { + refines Type2 +} + +@value interface Interface1<|#x> { + something (Type2) -> (Type1) +} + +@value interface Interface2 { + something (Type3) -> (Type2) +} + +@value interface Test1 { + refines Interface1 + refines Interface2 + + something (Type2) -> (Type2) +} + +@value interface Test2 { + refines Interface1 + refines Test1 + + // something must be merged again, since Interface1 is inherited again. +} diff --git a/src/Test/testfiles/bad_allows_variance_left.0rx b/src/Test/testfiles/bad_allows_variance_left.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/bad_allows_variance_left.0rx @@ -0,0 +1,5 @@ +@value interface Interface {} + +concrete Type<|#x> { + #x allows Interface +} diff --git a/src/Test/testfiles/bad_allows_variance_right.0rx b/src/Test/testfiles/bad_allows_variance_right.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/bad_allows_variance_right.0rx @@ -0,0 +1,5 @@ +@value interface Interface<|#x> {} + +concrete Type<#x|> { + #x allows Interface<#x> +} diff --git a/src/Test/testfiles/bad_defines_variance_left.0rx b/src/Test/testfiles/bad_defines_variance_left.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/bad_defines_variance_left.0rx @@ -0,0 +1,5 @@ +@type interface Interface {} + +concrete Type<#x|> { + #x defines Interface +} diff --git a/src/Test/testfiles/bad_defines_variance_right.0rx b/src/Test/testfiles/bad_defines_variance_right.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/bad_defines_variance_right.0rx @@ -0,0 +1,5 @@ +@type interface Interface<|#x> {} + +concrete Type<|#x> { + #x defines Interface<#x> +} diff --git a/src/Test/testfiles/bad_requires_variance_left.0rx b/src/Test/testfiles/bad_requires_variance_left.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/bad_requires_variance_left.0rx @@ -0,0 +1,5 @@ +@value interface Interface {} + +concrete Type<#x|> { + #x requires Interface +} diff --git a/src/Test/testfiles/bad_requires_variance_right.0rx b/src/Test/testfiles/bad_requires_variance_right.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/bad_requires_variance_right.0rx @@ -0,0 +1,5 @@ +@value interface Interface<|#x> {} + +concrete Type<|#x> { + #x requires Interface<#x> +} diff --git a/src/Test/testfiles/bad_type_arg_variance.0rx b/src/Test/testfiles/bad_type_arg_variance.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/bad_type_arg_variance.0rx @@ -0,0 +1,6 @@ +@value interface Type1<#x|> {} + +@type interface Type2<#x|> { + // contravariant * contravariant = covariant + something (Type1<#x>) -> () +} diff --git a/src/Test/testfiles/bad_type_return_variance.0rx b/src/Test/testfiles/bad_type_return_variance.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/bad_type_return_variance.0rx @@ -0,0 +1,5 @@ +@value interface Type1<#x|> {} + +@type interface Type2<|#x> { + something () -> (Type1<#x>) +} diff --git a/src/Test/testfiles/bad_value_arg_variance.0rx b/src/Test/testfiles/bad_value_arg_variance.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/bad_value_arg_variance.0rx @@ -0,0 +1,6 @@ +@value interface Type1<#x|> {} + +@value interface Type2<#x|> { + // contravariant * contravariant = covariant + something (Type1<#x>) -> () +} diff --git a/src/Test/testfiles/bad_value_return_variance.0rx b/src/Test/testfiles/bad_value_return_variance.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/bad_value_return_variance.0rx @@ -0,0 +1,5 @@ +@value interface Type1<#x|> {} + +@value interface Type2<|#x> { + something () -> (Type1<#x>) +} diff --git a/src/Test/testfiles/basic_crash_test.0rt b/src/Test/testfiles/basic_crash_test.0rt new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/basic_crash_test.0rt @@ -0,0 +1,15 @@ +testcase "basic crash test" { + crash Test$execute() + require "pattern in output 1" + exclude "pattern not in output 1" + require "pattern in output 2" + exclude "pattern not in output 2" +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { } +} diff --git a/src/Test/testfiles/basic_error_test.0rt b/src/Test/testfiles/basic_error_test.0rt new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/basic_error_test.0rt @@ -0,0 +1,15 @@ +testcase "basic error test" { + error + require compiler "pattern in output 1" + exclude stderr "pattern not in output 1" + require any "pattern in output 2" + exclude stdout "pattern not in output 2" +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { } +} diff --git a/src/Test/testfiles/basic_success_test.0rt b/src/Test/testfiles/basic_success_test.0rt new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/basic_success_test.0rt @@ -0,0 +1,15 @@ +testcase "basic success test" { + success Test$execute() + require "pattern in output 1" + exclude "pattern not in output 1" + require "pattern in output 2" + exclude "pattern not in output 2" +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { } +} diff --git a/src/Test/testfiles/category_function_param_match.0rx b/src/Test/testfiles/category_function_param_match.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/category_function_param_match.0rx @@ -0,0 +1,4 @@ +concrete Type<#x> { + @category something<#x> + () -> () +} diff --git a/src/Test/testfiles/concrete.0rx b/src/Test/testfiles/concrete.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/concrete.0rx @@ -0,0 +1,25 @@ +// A concrete type with contrived comments. +concrete/*!!!*/Type<#a,#b // <- contravariant params + |#c,#d // <- invariant params + |#e,#f /* <- covariant params*/> { + refines /* <- used with value interfaces */ Parent + refines Other,#f> + defines /* <- used with type interfaces */ Equals> + #a allows /* <- used with value-interface filters */ Parent + #b requires Type2<#a> + #c defines // <- used with type-interface filters + Equals<#c /* <- a type arg */> + + @category create<#x> + #x requires Type1 + () -> (optional Type1) + + @type create2<#y> + #y requires #x + #y allows T2 + #y defines T3 + () -> (optional #x) + + @value get () -> (Type1) + @value set (Type1) -> () +} diff --git a/src/Test/testfiles/concrete_defines_concrete.0rx b/src/Test/testfiles/concrete_defines_concrete.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/concrete_defines_concrete.0rx @@ -0,0 +1,5 @@ +concrete Parent {} + +concrete Child { + defines Parent +} diff --git a/src/Test/testfiles/concrete_defines_instance.0rx b/src/Test/testfiles/concrete_defines_instance.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/concrete_defines_instance.0rx @@ -0,0 +1,5 @@ +@type interface Parent {} + +concrete Child { + defines Parent +} diff --git a/src/Test/testfiles/concrete_defines_value.0rx b/src/Test/testfiles/concrete_defines_value.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/concrete_defines_value.0rx @@ -0,0 +1,5 @@ +@value interface Parent {} + +concrete Child { + defines Parent +} diff --git a/src/Test/testfiles/concrete_duplicate_param.0rx b/src/Test/testfiles/concrete_duplicate_param.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/concrete_duplicate_param.0rx @@ -0,0 +1,1 @@ +concrete Type<#x|#y|#x> {} diff --git a/src/Test/testfiles/concrete_instances.0rx b/src/Test/testfiles/concrete_instances.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/concrete_instances.0rx @@ -0,0 +1,33 @@ +// Setup. + +@type interface Type<#x|> { + #x requires Value0 +} + +@value interface Value0 {} + +@value interface Value1<|#y> { + #y requires Value0 +} + +@value interface Value2 { + refines Value0 +} + +@value interface Value3<|#z> { + #z defines Type +} + + +// Tests. + +concrete Object0 { + refines Value2 // -> Value0 + defines Type + refines Value1 +} + +concrete Object1 { + defines Type + refines Value3 +} diff --git a/src/Test/testfiles/concrete_missing_define.0rx b/src/Test/testfiles/concrete_missing_define.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/concrete_missing_define.0rx @@ -0,0 +1,22 @@ +// Setup. + +@type interface Type<#x|> { + #x requires Value0 +} + +@value interface Value0 {} + +@value interface Value1<|#y> { + #y requires Value0 +} + +@value interface Value3<|#z> { + #z defines Type +} + + +// Tests. + +concrete Object1 { + refines Value3 +} diff --git a/src/Test/testfiles/concrete_missing_refine.0rx b/src/Test/testfiles/concrete_missing_refine.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/concrete_missing_refine.0rx @@ -0,0 +1,23 @@ +// Setup. + +@type interface Type<#x|> { + x requires Value0 +} + +@value interface Value0 {} + +@value interface Value1<|#y> { + y requires Value0 +} + +@value interface Value2 { + refines Value0 +} + + +// Tests. + +concrete Object0 { + defines Type + refines Value1 +} diff --git a/src/Test/testfiles/concrete_refines_concrete.0rx b/src/Test/testfiles/concrete_refines_concrete.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/concrete_refines_concrete.0rx @@ -0,0 +1,5 @@ +concrete Parent {} + +concrete Child { + refines Parent +} diff --git a/src/Test/testfiles/concrete_refines_instance.0rx b/src/Test/testfiles/concrete_refines_instance.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/concrete_refines_instance.0rx @@ -0,0 +1,5 @@ +@type interface Parent {} + +concrete Child { + refines Parent +} diff --git a/src/Test/testfiles/concrete_refines_value.0rx b/src/Test/testfiles/concrete_refines_value.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/concrete_refines_value.0rx @@ -0,0 +1,5 @@ +@value interface Parent {} + +concrete Child { + refines Parent +} diff --git a/src/Test/testfiles/conflict_in_preserved.0rx b/src/Test/testfiles/conflict_in_preserved.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/conflict_in_preserved.0rx @@ -0,0 +1,33 @@ +@value interface Type1 {} + +@value interface Type2 { + refines Type1 +} + +@value interface Type3 { + refines Type2 +} + +@value interface Interface1 { + something (Type2) -> (Type1) +} + +@value interface Interface2 { + something (Type3) -> (Type2) +} + +@value interface Parent1 { + refines Interface1 + refines Interface2 + + something (Type3) -> (Type1) +} + +@value interface Parent2 { + refines Interface1 +} + +concrete Child { + refines Parent1 + refines Parent2 +} diff --git a/src/Test/testfiles/conflicting_declaration.0rx b/src/Test/testfiles/conflicting_declaration.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/conflicting_declaration.0rx @@ -0,0 +1,4 @@ +concrete Type { + @type something () -> () + @value something () -> (Type) +} diff --git a/src/Test/testfiles/conflicting_inherited.0rx b/src/Test/testfiles/conflicting_inherited.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/conflicting_inherited.0rx @@ -0,0 +1,12 @@ +@value interface Type1 { + something () -> () +} + +@value interface Type2 { + something () -> (Type) +} + +concrete Type3 { + refines Type1 + refines Type2 +} diff --git a/src/Test/testfiles/contravariant_defines_covariant.0rx b/src/Test/testfiles/contravariant_defines_covariant.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/contravariant_defines_covariant.0rx @@ -0,0 +1,5 @@ +@type interface Object1<|#x> {} + +concrete Object2<#y|> { + defines Object1<#y> +} diff --git a/src/Test/testfiles/contravariant_defines_invariant.0rx b/src/Test/testfiles/contravariant_defines_invariant.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/contravariant_defines_invariant.0rx @@ -0,0 +1,8 @@ +@value interface Object1<#x|> {} + +@type interface Object2<#z> {} + +concrete Object3<#y|> { + // Despite matching variance with Object1, Object2 turns it into invariant. + defines Object2> +} diff --git a/src/Test/testfiles/contravariant_refines_covariant.0rx b/src/Test/testfiles/contravariant_refines_covariant.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/contravariant_refines_covariant.0rx @@ -0,0 +1,5 @@ +@value interface Object1<|#x> {} + +@value interface Object2<#y|> { + refines Object1<#y> +} diff --git a/src/Test/testfiles/contravariant_refines_invariant.0rx b/src/Test/testfiles/contravariant_refines_invariant.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/contravariant_refines_invariant.0rx @@ -0,0 +1,8 @@ +@value interface Object1<#x|> {} + +@value interface Object2<#z> {} + +@value interface Object3<#y|> { + // Despite matching variance with Object1, Object2 turns it into invariant. + refines Object2> +} diff --git a/src/Test/testfiles/covariant_defines_contravariant.0rx b/src/Test/testfiles/covariant_defines_contravariant.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/covariant_defines_contravariant.0rx @@ -0,0 +1,5 @@ +@type interface Object1<#x|> {} + +concrete Object2<|#y> { + defines Object1<#y> +} diff --git a/src/Test/testfiles/covariant_defines_invariant.0rx b/src/Test/testfiles/covariant_defines_invariant.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/covariant_defines_invariant.0rx @@ -0,0 +1,8 @@ +@value interface Object1<|#x> {} + +@type interface Object2<#z> {} + +concrete Object3<|#y> { + // Despite matching variance with Object1, Object2 turns it into invariant. + defines Object2> +} diff --git a/src/Test/testfiles/covariant_refines_contravariant.0rx b/src/Test/testfiles/covariant_refines_contravariant.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/covariant_refines_contravariant.0rx @@ -0,0 +1,5 @@ +@value interface Object1<#x|> {} + +@value interface Object2<|#y> { + refines Object1<#y> +} diff --git a/src/Test/testfiles/covariant_refines_invariant.0rx b/src/Test/testfiles/covariant_refines_invariant.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/covariant_refines_invariant.0rx @@ -0,0 +1,8 @@ +@value interface Object1<|#x> {} + +@value interface Object2<#z> {} + +@value interface Object3<|#y> { + // Despite matching variance with Object1, Object2 turns it into invariant. + refines Object2> +} diff --git a/src/Test/testfiles/definitions.0rx b/src/Test/testfiles/definitions.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/definitions.0rx @@ -0,0 +1,17 @@ +define Type { + @value T<#x> val + + @type Type<#x> zzz <- Type<#x>{ T<#x>$create() } + + @category optional T something <- skip + + get () { + return val + } + + @value get2 () -> (T<#x>) + get2 () (v) { + v <- val + return _ + } +} diff --git a/src/Test/testfiles/duplicate_define.0rx b/src/Test/testfiles/duplicate_define.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/duplicate_define.0rx @@ -0,0 +1,12 @@ +@value interface Value0 {} + +@value interface Value1 { + refines Value0 +} + +@type interface Type0<|#x> {} + +concrete Object { + defines Type0 + defines Type0 +} diff --git a/src/Test/testfiles/duplicate_refine.0rx b/src/Test/testfiles/duplicate_refine.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/duplicate_refine.0rx @@ -0,0 +1,12 @@ +@value interface Value0 {} + +@value interface Value1 { + refines Value0 +} + +@value interface Value2<|#x> {} + +concrete Object { + refines Value2 + refines Value2 +} diff --git a/src/Test/testfiles/failed_merge.0rx b/src/Test/testfiles/failed_merge.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/failed_merge.0rx @@ -0,0 +1,24 @@ +@value interface Type1 {} + +@value interface Type2 { + refines Type1 +} + +@value interface Type3 { + refines Type2 +} + +@value interface Interface1 { + something (Type2) -> (Type1) +} + +@value interface Interface2 { + something (Type3) -> (Type2) +} + +concrete Test { + refines Interface1 + refines Interface2 + + @value something (Type1) -> (Type1) +} diff --git a/src/Test/testfiles/failed_merge_params.0rx b/src/Test/testfiles/failed_merge_params.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/failed_merge_params.0rx @@ -0,0 +1,33 @@ +@value interface Type1<#a> {} + +@value interface Type2<#b> { + refines Type1<#b> +} + +@value interface Type3<#c> { + refines Type2<#c> +} + +@value interface Interface1<#j> { + something<#x,#y> + #x requires Type2<#j> + #y allows Type1<#j> + (#x) -> (#y) +} + +@value interface Interface2<#k> { + something<#w,#z> + #w requires Type3<#k> + #z allows Type3<#k> + (#w) -> (#z) +} + +concrete Test<#q> { + refines Interface1<#q> + refines Interface2<#q> + + @value something<#r,#s> + #r requires Type2<#q> + #s allows Type2<#q> + (#r) -> (#s) +} diff --git a/src/Test/testfiles/filters.0rx b/src/Test/testfiles/filters.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/filters.0rx @@ -0,0 +1,23 @@ +@type interface Equals<#x|> {} + +@value interface Function<#y|#z> {} + +concrete Value0<#t,#w> { + #t allows #w + #t requires Function<#t,#w> + #w requires #t + #w defines Equals<#w> +} + +@value interface Value1 { + refines Function +} + +concrete Value2 { + refines Value3 + defines Equals +} + +concrete Value3 { + refines Value1 +} diff --git a/src/Test/testfiles/flatten.0rx b/src/Test/testfiles/flatten.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/flatten.0rx @@ -0,0 +1,27 @@ +@value interface Object1<#x,#y> { + refines Object3<#y> + // -> refines Object2 +} + +@value interface Object2 {} + +@value interface Object3<#x> { + refines Object2 +} + +@value interface Parent<#x> { + refines Object1<#x,Object3> + // -> refines Object3> + // -> refines Object2 +} + +@type interface Type<#x> {} + +concrete Child { + refines Parent + // -> refines Object1> + // -> refines Object3> + // -> refines Object2 + + defines Type +} diff --git a/src/Test/testfiles/function_allows_missed.0rx b/src/Test/testfiles/function_allows_missed.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/function_allows_missed.0rx @@ -0,0 +1,16 @@ +@type interface Type1 {} + +@value interface Type2 {} + +@value interface Type3 {} + +concrete Type4<#x> { + #x requires Type2 + #x allows Type3 + #x defines Type1 + + @type something<#y> + #y requires Type2 + #y defines Type1 + () -> (Type4<#y>) +} diff --git a/src/Test/testfiles/function_bad_allows_type.0rx b/src/Test/testfiles/function_bad_allows_type.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/function_bad_allows_type.0rx @@ -0,0 +1,9 @@ +@value interface Interface<#x> { + #x requires Formatted +} + +concrete Type<#x> { + @type something<#y> + #y allows Interface<#x> + () -> () +} diff --git a/src/Test/testfiles/function_bad_allows_variance.0rx b/src/Test/testfiles/function_bad_allows_variance.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/function_bad_allows_variance.0rx @@ -0,0 +1,7 @@ +@value interface Interface<#x|> {} + +concrete Type<|#x> { + @value something<#y> + #y allows Interface<#x> + () -> () +} diff --git a/src/Test/testfiles/function_bad_arg.0rx b/src/Test/testfiles/function_bad_arg.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/function_bad_arg.0rx @@ -0,0 +1,9 @@ +@value interface Type0 {} + +@value interface Type1<#x> { + #x requires Type0 +} + +concrete Type { + @value something (Type1<#x>) -> () +} diff --git a/src/Test/testfiles/function_bad_defines_type.0rx b/src/Test/testfiles/function_bad_defines_type.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/function_bad_defines_type.0rx @@ -0,0 +1,9 @@ +@type interface Interface<#x> { + #x requires Formatted +} + +concrete Type<#x> { + @type something<#y> + #y defines Interface<#x> + () -> () +} diff --git a/src/Test/testfiles/function_bad_defines_variance.0rx b/src/Test/testfiles/function_bad_defines_variance.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/function_bad_defines_variance.0rx @@ -0,0 +1,7 @@ +@type interface Interface<|#x> {} + +concrete Type<|#x> { + @value something<#y> + #y defines Interface<#x> + () -> () +} diff --git a/src/Test/testfiles/function_bad_filter_param.0rx b/src/Test/testfiles/function_bad_filter_param.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/function_bad_filter_param.0rx @@ -0,0 +1,5 @@ +concrete Type { + @value something + y allows Type + () -> () +} diff --git a/src/Test/testfiles/function_bad_requires_type.0rx b/src/Test/testfiles/function_bad_requires_type.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/function_bad_requires_type.0rx @@ -0,0 +1,9 @@ +@type interface Interface<#x> { + #x requires Formatted +} + +concrete Type<#x> { + @type something<#y> + #y requires Interface<#x> + () -> () +} diff --git a/src/Test/testfiles/function_bad_requires_variance.0rx b/src/Test/testfiles/function_bad_requires_variance.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/function_bad_requires_variance.0rx @@ -0,0 +1,7 @@ +@value interface Interface<|#x> {} + +concrete Type<|#x> { + @value something<#y> + #y requires Interface<#x> + () -> () +} diff --git a/src/Test/testfiles/function_bad_return.0rx b/src/Test/testfiles/function_bad_return.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/function_bad_return.0rx @@ -0,0 +1,9 @@ +@value interface Type0 {} + +@value interface Type1<#x> { + #x requires Type0 +} + +concrete Type { + @value something () -> (Type1<#x>) +} diff --git a/src/Test/testfiles/function_defines_missed.0rx b/src/Test/testfiles/function_defines_missed.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/function_defines_missed.0rx @@ -0,0 +1,16 @@ +@type interface Type1 {} + +@value interface Type2 {} + +@value interface Type3 {} + +concrete Type4<#x> { + #x requires Type2 + #x allows Type3 + #x defines Type1 + + @type something<#y> + #y requires Type2 + #y allows Type3 + () -> (Type4<#y>) +} diff --git a/src/Test/testfiles/function_duplicate_param.0rx b/src/Test/testfiles/function_duplicate_param.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/function_duplicate_param.0rx @@ -0,0 +1,4 @@ +concrete Type { + @value something<#x,#x> + () -> () +} diff --git a/src/Test/testfiles/function_filters_satisfied.0rx b/src/Test/testfiles/function_filters_satisfied.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/function_filters_satisfied.0rx @@ -0,0 +1,23 @@ +@type interface Type1<#x> {} + +@value interface Type2<#x> {} + +@value interface Type3<#x> {} + +concrete Type4<#x> { + #x requires Type2<#x> + #x allows Type3<#x> + #x defines Type1<#x> + + @type something<#y> + #y requires Type2<#y> + #y allows Type3<#y> + #y defines Type1<#y> + () -> (Type4<#y>) + + @type something2<#y> + #y requires #x + #y allows #x + #y defines Type1<#y> + () -> (Type4<#y>) +} diff --git a/src/Test/testfiles/function_param_clash.0rx b/src/Test/testfiles/function_param_clash.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/function_param_clash.0rx @@ -0,0 +1,4 @@ +concrete Type<#x> { + @value something<#x> + () -> () +} diff --git a/src/Test/testfiles/function_requires_missed.0rx b/src/Test/testfiles/function_requires_missed.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/function_requires_missed.0rx @@ -0,0 +1,16 @@ +@type interface Type1 {} + +@value interface Type2 {} + +@value interface Type3 {} + +concrete Type4<#x> { + #x requires Type2 + #x allows Type3 + #x defines Type1 + + @type something<#y> + #y allows Type3 + #y defines Type1 + () -> (Type4<#y>) +} diff --git a/src/Test/testfiles/inherit_incompatible.0rx b/src/Test/testfiles/inherit_incompatible.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/inherit_incompatible.0rx @@ -0,0 +1,24 @@ +@value interface Base {} + +@value interface Child1 { + refines Base +} + +@value interface Child2 { + refines Base +} + +@value interface Inherit<#x|> {} + +@value interface Parent1 { + refines Inherit +} + +@value interface Parent2 { + refines Inherit +} + +concrete Test { + refines Parent1 + refines Parent2 +} diff --git a/src/Test/testfiles/internal_filters.0rx b/src/Test/testfiles/internal_filters.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/internal_filters.0rx @@ -0,0 +1,7 @@ +define Type { + types<#x,#y,#z> { + #x requires Type1 + #y allows Type2 + #z defines Type3 + } +} diff --git a/src/Test/testfiles/internal_inheritance.0rx b/src/Test/testfiles/internal_inheritance.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/internal_inheritance.0rx @@ -0,0 +1,4 @@ +define Type { + refines Formatted + defines LessThan +} diff --git a/src/Test/testfiles/internal_params.0rx b/src/Test/testfiles/internal_params.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/internal_params.0rx @@ -0,0 +1,3 @@ +define Type { + types<#x,#y,#z> {} +} diff --git a/src/Test/testfiles/merge_different_scopes.0rx b/src/Test/testfiles/merge_different_scopes.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/merge_different_scopes.0rx @@ -0,0 +1,14 @@ +@value interface Type1 { + something () -> () +} + +@type interface Type2 { + something () -> () +} + +concrete Type3 { + refines Type1 + defines Type2 + + @value something () -> () +} diff --git a/src/Test/testfiles/merge_incompatible.0rx b/src/Test/testfiles/merge_incompatible.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/merge_incompatible.0rx @@ -0,0 +1,25 @@ +@value interface Base {} + +@value interface Child1 { + refines Base +} + +@value interface Child2 { + refines Base +} + +@value interface Inherit<#x|> {} + +@value interface Parent1 { + refines Inherit +} + +@value interface Parent2 { + refines Inherit +} + +concrete Test { + refines Parent1 + refines Parent2 + refines Inherit +} diff --git a/src/Test/testfiles/merge_with_refine.0rx b/src/Test/testfiles/merge_with_refine.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/merge_with_refine.0rx @@ -0,0 +1,19 @@ +@value interface Type1 { + get () -> (Type1) +} + +@value interface Type2 { + refines Type1 +} + +@value interface Test1 { + refines Type2 + + get () -> (Test1) +} + +concrete Test2 { + refines Type2 + + @value get () -> (Test2) +} diff --git a/src/Test/testfiles/merged.0rx b/src/Test/testfiles/merged.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/merged.0rx @@ -0,0 +1,35 @@ +@value interface Value0 {} + +@value interface Value1 { + refines Value0 +} + +@value interface Value2 { + refines Value1 +} + +@value interface Value3 { + refines Value0 +} + +@value interface Value4<#x|#y> {} + +@type interface Type0<#x|#y> {} + +@value interface Inherit1 { + refines Value4 +} + +@value interface Inherit2 { + refines Value4 +} + +concrete Test { + refines Value0 + refines Value1 + refines Value2 // -> Value1 -> Value0 + refines Value3 // -> Value0 + + refines Inherit1 + refines Inherit2 +} diff --git a/src/Test/testfiles/partial.0rx b/src/Test/testfiles/partial.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/partial.0rx @@ -0,0 +1,5 @@ +concrete Child { + refines Parent + // -> Object1 + // -> Object2 +} diff --git a/src/Test/testfiles/partial_params.0rx b/src/Test/testfiles/partial_params.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/partial_params.0rx @@ -0,0 +1,3 @@ +concrete Child<#x|#y> { + refines Parent<#x,#y> +} diff --git a/src/Test/testfiles/preserve_merged.0rx b/src/Test/testfiles/preserve_merged.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/preserve_merged.0rx @@ -0,0 +1,28 @@ +@value interface Type1 {} + +@value interface Type2 { + refines Type1 +} + +@value interface Type3 { + refines Type2 +} + +@value interface Interface1 { + something (Type2) -> (Type1) +} + +@value interface Interface2 { + something (Type3) -> (Type2) +} + +@value interface Parent { + refines Interface1 + refines Interface2 + + something (Type2) -> (Type2) +} + +concrete Child { + refines Parent +} diff --git a/src/Test/testfiles/procedures.0rx b/src/Test/testfiles/procedures.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/procedures.0rx @@ -0,0 +1,47 @@ +testFunction1 (a,b,c) (d,e,f) { + if (T$f()) { + // do nothing + } elif (#q$r().f()) { + ~ require(v).g() + } elif (zzz) { + // sleep + } + + x <- Type<#z,T<#m>>{ r, Type$new() } + + x <- empty + + scoped { + optional T myvar <- reduce<#x,#y>(q) + } in if (present(myvar)) { + ~ unqualified() + } else { + // something + } + + scoped { + optional T myvar <- reduce<#x,#y>(q) + } in { v, _ } <- x.process(myvar) + + scoped { + // ... + } cleanup { + x <- y + } in ~ x.process() + + ~ z.call().call() + { x, weak [#k|Type] y, _ } <- z.call() + x <- z.T<#z>$call().call() + return _ + return a + return { a, z.call().call(), c } + + while (true) { + ~ failure.to().execute() + return x + } update { + x <- y + } +} + +testFunction2 (a,b,c) {} diff --git a/src/Test/testfiles/refine_wrong_direction.0rx b/src/Test/testfiles/refine_wrong_direction.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/refine_wrong_direction.0rx @@ -0,0 +1,16 @@ +@value interface Type1 {} + +@value interface Type2 { + refines Type1 +} + +@value interface Inherited<|#x> {} + +@value interface Parent { + refines Inherited +} + +concrete Child { + refines Parent + refines Inherited +} diff --git a/src/Test/testfiles/requires_concrete.0rx b/src/Test/testfiles/requires_concrete.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/requires_concrete.0rx @@ -0,0 +1,3 @@ +concrete Type<#x> { + #x requires Type<#x> +} diff --git a/src/Test/testfiles/resolved_in_preserved.0rx b/src/Test/testfiles/resolved_in_preserved.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/resolved_in_preserved.0rx @@ -0,0 +1,35 @@ +@value interface Type1 {} + +@value interface Type2 { + refines Type1 +} + +@value interface Type3 { + refines Type2 +} + +@value interface Interface1 { + something (Type2) -> (Type1) +} + +@value interface Interface2 { + something (Type3) -> (Type2) +} + +@value interface Parent1 { + refines Interface1 + refines Interface2 + + something (Type2) -> (Type2) +} + +@value interface Parent2 { + refines Interface1 +} + +concrete Child { + refines Parent1 + refines Parent2 + + @value something (Type2) -> (Type2) +} diff --git a/src/Test/testfiles/successful_merge.0rx b/src/Test/testfiles/successful_merge.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/successful_merge.0rx @@ -0,0 +1,31 @@ +@value interface Type1 {} + +@value interface Type2 { + refines Type1 +} + +@value interface Type3 { + refines Type2 +} + +@value interface Interface1<|#x> { + something (Type2) -> (Type1) +} + +@value interface Interface2 { + something (Type3) -> (Type2) +} + +@value interface Test1 { + refines Interface1 + refines Interface2 + + something (Type2) -> (Type2) +} + +@value interface Test2 { + refines Interface1 + refines Test1 + + something (Type2) -> (Type2) +} diff --git a/src/Test/testfiles/successful_merge_params.0rx b/src/Test/testfiles/successful_merge_params.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/successful_merge_params.0rx @@ -0,0 +1,33 @@ +@value interface Type1<#a> {} + +@value interface Type2<#b> { + refines Type1<#b> +} + +@value interface Type3<#c> { + refines Type2<#c> +} + +@value interface Interface1<#j> { + something<#x,#y> + #x requires Type2<#j> + #y allows Type1<#j> + (#x) -> (#y) +} + +@value interface Interface2<#k> { + something<#w,#z> + #w requires Type3<#k> + #z allows Type1<#k> + (#w) -> (#z) +} + +concrete Test<#q> { + refines Interface1<#q> + refines Interface2<#q> + + @value something<#r,#s> + #r requires Type2<#q> + #s allows Type2<#q> + (#r) -> (#s) +} diff --git a/src/Test/testfiles/type_duplicate_param.0rx b/src/Test/testfiles/type_duplicate_param.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/type_duplicate_param.0rx @@ -0,0 +1,1 @@ +@type interface Type<#x|#y|#x> {} diff --git a/src/Test/testfiles/type_instances.0rx b/src/Test/testfiles/type_instances.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/type_instances.0rx @@ -0,0 +1,33 @@ +// Setup. + +@type interface Type<#x|> { + #x requires Value0 +} + +@value interface Value0 {} + +@value interface Value1<|#y> { + #y requires Value0 +} + +@value interface Value2 { + refines Value0 +} + +@value interface Value3<|#z> { + #z defines Type +} + + +// Tests. + +@type interface Object0<#x> { + #x requires Value2 // -> Value0 + #x defines Type<#x> + #x requires Value1<#x> +} + +@type interface Object1<#x> { + #x defines Type + #x requires Value3<#x> +} diff --git a/src/Test/testfiles/type_interface.0rx b/src/Test/testfiles/type_interface.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/type_interface.0rx @@ -0,0 +1,13 @@ +@type interface Type<#a,#b|#c,#d|#e,#f> { + #a allows Parent + #b requires Type2<#a> + #c defines Equals<#c> + + create () -> (optional #x) + + create2<#y> + #y requires #x + #y allows T2 + #y defines T3 + () -> (optional #x) +} diff --git a/src/Test/testfiles/type_missing_define.0rx b/src/Test/testfiles/type_missing_define.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/type_missing_define.0rx @@ -0,0 +1,22 @@ +// Setup. + +@type interface Type<#x|> { + #x requires Value0 +} + +@value interface Value0 {} + +@value interface Value1<|#y> { + #y requires Value0 +} + +@value interface Value3<|#z> { + #z defines Type +} + + +// Tests. + +@type interface Object1<#x> { + #x requires Value3<#x> +} diff --git a/src/Test/testfiles/type_missing_refine.0rx b/src/Test/testfiles/type_missing_refine.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/type_missing_refine.0rx @@ -0,0 +1,23 @@ +// Setup. + +@type interface Type<#x|> { + #x requires Value0 +} + +@value interface Value0 {} + +@value interface Value1<|#y> { + #y requires Value0 +} + +@value interface Value2 { + refines Value0 +} + + +// Tests. + +@type interface Object0<#x> { + #x defines Type<#x> + #x requires Value1<#x> +} diff --git a/src/Test/testfiles/valid_filter_variance.0rx b/src/Test/testfiles/valid_filter_variance.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/valid_filter_variance.0rx @@ -0,0 +1,17 @@ +@value interface Interface1<#x|> {} + +concrete Type1<#x|> { + #x allows Interface1<#x> +} + +@type interface Interface2<#x|> {} + +concrete Type2<|#x> { + #x defines Interface2<#x> +} + +@value interface Interface3<#x|> {} + +concrete Type3<|#x> { + #x requires Interface3<#x> +} diff --git a/src/Test/testfiles/valid_function_variance.0rx b/src/Test/testfiles/valid_function_variance.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/valid_function_variance.0rx @@ -0,0 +1,13 @@ +@value interface Type1<#x|> {} + +@value interface Type2<#x|> { + // arg: contravariant * contravariant * contravariant = contravariant + // return: contravariant * contravariant = covariant + something (Type1>) -> (Type1<#x>) +} + +@type interface Type3<#x|> { + // arg: contravariant * contravariant * contravariant = contravariant + // return: contravariant * contravariant = covariant + something (Type1>) -> (Type1<#x>) +} diff --git a/src/Test/testfiles/valid_variances.0rx b/src/Test/testfiles/valid_variances.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/valid_variances.0rx @@ -0,0 +1,24 @@ +@value interface Object1<#x|> {} + +@value interface Object2<|#y> {} + +@value interface Object3<#w|#z> { + refines Object1<#w> + refines Object2<#z> +} + +@value interface Object4<#t> { + refines Object3<#t,#t> +} + +@value interface Object5<|#q> { + // Variance reversed twice by Object1. + refines Object1> +} + +@type interface Object6<|#x> {} + +concrete Object7<|#s> { + // Variance reversed twice by Object1. + defines Object6>> +} diff --git a/src/Test/testfiles/value_cycle.0rx b/src/Test/testfiles/value_cycle.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/value_cycle.0rx @@ -0,0 +1,11 @@ +@value interface Type1 { + refines Type2 +} + +@value interface Type2 { + refines Type3 +} + +@value interface Type3 { + refines Type1 +} diff --git a/src/Test/testfiles/value_duplicate_param.0rx b/src/Test/testfiles/value_duplicate_param.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/value_duplicate_param.0rx @@ -0,0 +1,1 @@ +@value interface Type<#x|#y|#x> {} diff --git a/src/Test/testfiles/value_instances.0rx b/src/Test/testfiles/value_instances.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/value_instances.0rx @@ -0,0 +1,33 @@ +// Setup. + +@type interface Type<#x|> { + #x requires Value0 +} + +@value interface Value0 {} + +@value interface Value1<|#y> { + #y requires Value0 +} + +@value interface Value2 { + refines Value0 +} + +@value interface Value3<|#z> { + #z defines Type +} + + +// Tests. + +@value interface Object0<#x> { + #x requires Value2 // -> Value0 + #x defines Type<#x> + #x requires Value1<#x> +} + +@value interface Object1<#x> { + #x defines Type + #x requires Value3<#x> +} diff --git a/src/Test/testfiles/value_interface.0rx b/src/Test/testfiles/value_interface.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/value_interface.0rx @@ -0,0 +1,16 @@ +@value interface Type<#a,#b|#c,#d|#e,#f> { + refines Parent + refines Other,#f> + #a allows Parent + #b requires Type2<#a> + #c defines Equals<#c> + + get () -> (#x) + set (#x) -> () + + something<#y> + #y requires T1 + #y allows T2 + #y defines T3 + (#y) -> (#y) +} diff --git a/src/Test/testfiles/value_missing_define.0rx b/src/Test/testfiles/value_missing_define.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/value_missing_define.0rx @@ -0,0 +1,22 @@ +// Setup. + +@type interface Type<#x|> { + #x requires Value0 +} + +@value interface Value0 {} + +@value interface Value1<|#y> { + #y requires Value0 +} + +@value interface Value3<|#z> { + #z defines Type +} + + +// Tests. + +@value interface Object1<#x> { + #x requires Value3<#x> +} diff --git a/src/Test/testfiles/value_missing_refine.0rx b/src/Test/testfiles/value_missing_refine.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/value_missing_refine.0rx @@ -0,0 +1,23 @@ +// Setup. + +@type interface Type<#x|> { + #x requires Value0 +} + +@value interface Value0 {} + +@value interface Value1<|#y> { + #y requires Value0 +} + +@value interface Value2 { + refines Value0 +} + + +// Tests. + +@value interface Object0<#x> { + #x defines Type<#x> + #x requires Value1<#x> +} diff --git a/src/Test/testfiles/value_refines_concrete.0rx b/src/Test/testfiles/value_refines_concrete.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/value_refines_concrete.0rx @@ -0,0 +1,5 @@ +concrete Parent {} + +@value interface Child { + refines Parent +} diff --git a/src/Test/testfiles/value_refines_instance.0rx b/src/Test/testfiles/value_refines_instance.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/value_refines_instance.0rx @@ -0,0 +1,5 @@ +@type interface Parent {} + +@value interface Child { + refines Parent +} diff --git a/src/Test/testfiles/value_refines_value.0rx b/src/Test/testfiles/value_refines_value.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/value_refines_value.0rx @@ -0,0 +1,5 @@ +@value interface Parent {} + +@value interface Child { + refines Parent +} diff --git a/src/Test/testfiles/weak_arg.0rx b/src/Test/testfiles/weak_arg.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/weak_arg.0rx @@ -0,0 +1,3 @@ +@value interface Type { + get () -> (weak Type) +} diff --git a/src/Test/testfiles/weak_return.0rx b/src/Test/testfiles/weak_return.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/weak_return.0rx @@ -0,0 +1,3 @@ +@value interface Type { + set (weak Type) -> () +} diff --git a/src/Types/Builtin.hs b/src/Types/Builtin.hs new file mode 100644 --- /dev/null +++ b/src/Types/Builtin.hs @@ -0,0 +1,55 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Types.Builtin ( + boolRequiredValue, + charRequiredValue, + defaultCategories, + emptyValue, + floatRequiredValue, + formattedRequiredValue, + intRequiredValue, + stringRequiredValue, +) where + +import qualified Data.Map as Map + +import Types.GeneralType +import Types.TypeCategory +import Types.TypeInstance + + +defaultCategories :: CategoryMap c +defaultCategories = Map.empty + +boolRequiredValue :: ValueType +boolRequiredValue = requiredSingleton BuiltinBool +stringRequiredValue :: ValueType +stringRequiredValue = requiredSingleton BuiltinString +charRequiredValue :: ValueType +charRequiredValue = requiredSingleton BuiltinChar +intRequiredValue :: ValueType +intRequiredValue = requiredSingleton BuiltinInt +floatRequiredValue :: ValueType +floatRequiredValue = requiredSingleton BuiltinFloat +formattedRequiredValue :: ValueType +formattedRequiredValue = requiredSingleton BuiltinFormatted +emptyValue :: ValueType +emptyValue = ValueType OptionalValue $ TypeMerge MergeUnion [] diff --git a/src/Types/DefinedCategory.hs b/src/Types/DefinedCategory.hs new file mode 100644 --- /dev/null +++ b/src/Types/DefinedCategory.hs @@ -0,0 +1,180 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Types.DefinedCategory ( + DefinedCategory(..), + DefinedMember(..), + VariableValue(..), + isInitialized, + mapMembers, + mergeInternalInheritance, + pairProceduresToFunctions, + setInternalFunctions, +) where + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Base.CompileError +import Base.Mergeable +import Types.Function +import Types.Positional +import Types.Procedure +import Types.TypeCategory +import Types.TypeInstance + + +data DefinedCategory c = + DefinedCategory { + dcContext :: [c], + dcName :: CategoryName, + dcParams :: [ValueParam c], + dcRefines :: [ValueRefine c], + dcDefines :: [ValueDefine c], + dcParamFilter :: [ParamFilter c], + dcMembers :: [DefinedMember c], + dcProcedures :: [ExecutableProcedure c], + dcFunctions :: [ScopedFunction c] + } + deriving (Show) -- TODO: Implement Show. + +data DefinedMember c = + DefinedMember { + dmContext :: [c], + dmScope :: SymbolScope, + dmType :: ValueType, + dmName :: VariableName, + dmInit :: Maybe (Expression c) + } + deriving (Show) -- TODO: Implement Show. + +isInitialized :: DefinedMember c -> Bool +isInitialized = check . dmInit where + check Nothing = False + check _ = True + +data VariableValue c = + VariableValue { + vvContext :: [c], + vvScope :: SymbolScope, + vvType :: ValueType, + vvWritable :: Bool + } + +setInternalFunctions :: (Show c, CompileErrorM m, MergeableM m, TypeResolver r) => + r -> AnyCategory c -> [ScopedFunction c] -> + m (Map.Map FunctionName (ScopedFunction c)) +setInternalFunctions r t fs = foldr update (return start) fs where + start = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions t + filters = getCategoryFilterMap t + update f@(ScopedFunction c n t2 s as rs ps fs ms) fa = do + validateCategoryFunction r t f + fa' <- fa + case n `Map.lookup` fa' of + Nothing -> return $ Map.insert n f fa' + (Just f0@(ScopedFunction c2 _ _ _ _ _ _ _ ms2)) -> do + flip reviseError ("In function merge:\n---\n" ++ show f0 ++ + "\n ->\n" ++ show f ++ "\n---\n") $ do + f0' <- parsedToFunctionType f0 + f' <- parsedToFunctionType f + checkFunctionConvert r filters f0' f' + return $ Map.insert n (ScopedFunction (c++c2) n t2 s as rs ps fs ([f0]++ms++ms2)) fa' + +pairProceduresToFunctions :: (Show c, CompileErrorM m, MergeableM m) => + Map.Map FunctionName (ScopedFunction c) -> [ExecutableProcedure c] -> + m [(ScopedFunction c,ExecutableProcedure c)] +pairProceduresToFunctions fa ps = do + pa <- foldr updateProcedure (return Map.empty) ps + let allNames = Set.union (Map.keysSet fa) (Map.keysSet pa) + foldr (updatePairs fa pa) (return []) $ Set.toList allNames + where + updateProcedure p pa = do + pa' <- pa + case epName p `Map.lookup` pa' of + Nothing -> return () + -- TODO: The error might show things in the wrong order. + (Just p0) -> compileError $ "Procedure " ++ show (epName p) ++ + formatFullContextBrace (epContext p) ++ + " is already defined" ++ + formatFullContextBrace (epContext p0) + return $ Map.insert (epName p) p pa' + updatePairs fa pa n ps = do + ps' <- ps + p <- getPair (n `Map.lookup` fa) (n `Map.lookup` pa) + return (p:ps') + getPair (Just f) Nothing = + compileError $ "Function " ++ show (sfName f) ++ + formatFullContextBrace (sfContext f) ++ + " has no procedure definition" + getPair Nothing (Just p) = + compileError $ "Procedure " ++ show (epName p) ++ + formatFullContextBrace (epContext p) ++ + " does not correspond to a function" + getPair (Just f) (Just p) = do + processPairs alwaysPair (sfArgs f) (avNames $ epArgs p) `reviseError` + ("Procedure for " ++ show (sfName f) ++ + formatFullContextBrace (avContext $ epArgs p) ++ + " has the wrong number of arguments" ++ + formatFullContextBrace (sfContext f)) + if isUnnamedReturns (epReturns p) + then return () + else do + processPairs alwaysPair (sfReturns f) (nrNames $ epReturns p) `reviseError` + ("Procedure for " ++ show (sfName f) ++ + formatFullContextBrace (nrContext $ epReturns p) ++ + " has the wrong number of returns" ++ + formatFullContextBrace (sfContext f)) + return () + return (f,p) + +mapMembers :: (Show c, CompileErrorM m, MergeableM m) => + [DefinedMember c] -> m (Map.Map VariableName (VariableValue c)) +mapMembers ms = foldr update (return Map.empty) ms where + update m ma = do + ma' <- ma + case dmName m `Map.lookup` ma' of + Nothing -> return () + -- TODO: The error might show things in the wrong order. + (Just m0) -> compileError $ "Member " ++ show (dmName m) ++ + formatFullContextBrace (dmContext m) ++ + " is already defined" ++ + formatFullContextBrace (vvContext m0) + return $ Map.insert (dmName m) (VariableValue (dmContext m) (dmScope m) (dmType m) True) ma' + +-- TODO: Most of this duplicates parts of flattenAllConnections. +mergeInternalInheritance :: (Show c, CompileErrorM m, MergeableM m) => + CategoryMap c -> DefinedCategory c -> m (CategoryMap c) +mergeInternalInheritance tm d = do + let rs2 = dcRefines d + let ds2 = dcDefines d + (_,t@(ValueConcrete c ns n ps rs ds vs fs)) <- getConcreteCategory tm ([],dcName d) + let c2 = ValueConcrete c ns n ps (rs++rs2) (ds++ds2) vs fs + let tm' = Map.insert (dcName d) c2 tm + let r = CategoryResolver tm' + let fm = getCategoryFilterMap t + rs' <- mergeRefines r fm (rs++rs2) + noDuplicateRefines [] n rs' + ds' <- mergeDefines r fm (ds++ds2) + noDuplicateDefines [] n ds' + fs' <- mergeFunctions r tm' fm rs' ds' fs + let c2' = ValueConcrete c ns n ps rs' ds' vs fs' + let tm0 = (dcName d) `Map.delete` tm + checkCategoryInstances tm0 [c2'] + return $ Map.insert (dcName d) c2' tm diff --git a/src/Types/Function.hs b/src/Types/Function.hs new file mode 100644 --- /dev/null +++ b/src/Types/Function.hs @@ -0,0 +1,130 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Types.Function ( + FunctionType(..), + assignFunctionParams, + checkFunctionConvert, + validatateFunctionType, +) where + +import Data.List (group,intercalate,sort) +import Control.Monad (when) +import qualified Data.Map as Map + +import Base.CompileError +import Base.Mergeable +import Types.GeneralType +import Types.Positional +import Types.TypeInstance +import Types.Variance + + +data FunctionType = + FunctionType { + ftArgs :: Positional ValueType, + ftReturns :: Positional ValueType, + ftParams :: Positional ParamName, + ftFilters :: Positional [TypeFilter] + } + deriving (Eq) + +instance Show FunctionType where + show (FunctionType as rs ps fa) = + "<" ++ intercalate "," (map show $ pValues ps) ++ "> " ++ + concat (concat $ map showFilters $ zip (pValues ps) (pValues fa)) ++ + "(" ++ intercalate "," (map show $ pValues as) ++ ") -> " ++ + "(" ++ intercalate "," (map show $ pValues rs) ++ ")" + where + showFilters (n,fs) = map (\f -> show n ++ " " ++ show f ++ " ") fs + +validatateFunctionType :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> ParamVariances -> FunctionType -> m () +validatateFunctionType r fm vm (FunctionType as rs ps fa) = do + mergeAllM $ map checkCount $ group $ sort $ pValues ps + mergeAllM $ map checkHides $ pValues ps + paired <- processPairs alwaysPair ps fa + let allFilters = Map.union fm (Map.fromList paired) + expanded <- fmap concat $ processPairs (\n fs -> return $ zip (repeat n) fs) ps fa + mergeAllM $ map (checkFilterType allFilters) expanded + mergeAllM $ map checkFilterVariance expanded + mergeAllM $ map (checkArg allFilters) $ pValues as + mergeAllM $ map (checkReturn allFilters) $ pValues rs + where + allVariances = Map.union vm (Map.fromList $ zip (pValues ps) (repeat Invariant)) + checkCount xa@(x:_:_) = + compileError $ "Param " ++ show x ++ " occurs " ++ show (length xa) ++ " times" + checkCount _ = return () + checkHides n = + when (n `Map.member` fm) $ + compileError $ "Param " ++ show n ++ " hides another param in a higher scope" + checkFilterType fa (n,f) = + validateTypeFilter r fa f `reviseError` ("In filter " ++ show n ++ " " ++ show f) + checkFilterVariance (n,f@(TypeFilter FilterRequires t)) = + validateInstanceVariance r allVariances Contravariant (SingleType t) `reviseError` + ("In filter " ++ show n ++ " " ++ show f) + checkFilterVariance (n,f@(TypeFilter FilterAllows t)) = + validateInstanceVariance r allVariances Covariant (SingleType t) `reviseError` + ("In filter " ++ show n ++ " " ++ show f) + checkFilterVariance (n,f@(DefinesFilter t)) = + validateDefinesVariance r allVariances Contravariant t `reviseError` + ("In filter " ++ show n ++ " " ++ show f) + checkArg fa ta@(ValueType _ t) = flip reviseError ("In argument " ++ show ta) $ do + when (isWeakValue ta) $ compileError "Weak values not allowed as argument types" + validateGeneralInstance r fa t + validateInstanceVariance r allVariances Contravariant t + checkReturn fa ta@(ValueType _ t) = flip reviseError ("In return " ++ show ta) $ do + when (isWeakValue ta) $ compileError "Weak values not allowed as return types" + validateGeneralInstance r fa t + validateInstanceVariance r allVariances Covariant t + +assignFunctionParams :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> Positional GeneralInstance -> + FunctionType -> m FunctionType +assignFunctionParams r fm ts ff@(FunctionType as rs ps fa) = do + mergeAllM $ map (validateGeneralInstance r fm) $ pValues ts + assigned <- fmap Map.fromList $ processPairs alwaysPair ps ts + let allAssigned = Map.union assigned (Map.fromList $ map (\n -> (n,SingleType $ JustParamName n)) $ Map.keys fm) + fa' <- fmap Positional $ collectAllOrErrorM $ map (assignFilters allAssigned) (pValues fa) + processPairs (validateAssignment r fm) ts fa' + as' <- fmap Positional $ collectAllOrErrorM $ + map (uncheckedSubValueType $ getValueForParam allAssigned) (pValues as) + rs' <- fmap Positional $ collectAllOrErrorM $ + map (uncheckedSubValueType $ getValueForParam allAssigned) (pValues rs) + return $ FunctionType as' rs' (Positional []) (Positional []) + where + assignFilters fm fs = collectAllOrErrorM $ map (uncheckedSubFilter $ getValueForParam fm) fs + +checkFunctionConvert :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> FunctionType -> FunctionType -> m () +checkFunctionConvert r fm ff1@(FunctionType as1 rs1 ps1 fa1) ff2 = do + mapped <- fmap Map.fromList $ processPairs alwaysPair ps1 fa1 + let fm' = Map.union fm mapped + let asTypes = Positional $ map (SingleType . JustParamName) $ pValues ps1 + -- Substitute params from ff2 into ff1. + (FunctionType as2 rs2 _ _) <- assignFunctionParams r fm' asTypes ff2 + fixed <- processPairs alwaysPair ps1 fa1 + let fm' = Map.union fm (Map.fromList fixed) + processPairs (validateArg fm') as1 as2 + processPairs (validateReturn fm') rs1 rs2 + return () + where + validateArg fm a1 a2 = checkValueTypeMatch r fm a1 a2 + validateReturn fm r1 r2 = checkValueTypeMatch r fm r2 r1 diff --git a/src/Types/GeneralType.hs b/src/Types/GeneralType.hs new file mode 100644 --- /dev/null +++ b/src/Types/GeneralType.hs @@ -0,0 +1,53 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Types.GeneralType ( + GeneralType(..), + MergeType(..), + checkGeneralType, +) where + +import Base.CompileError +import Base.Mergeable + + +data MergeType = + MergeUnion | + MergeIntersect + deriving (Eq,Ord) + +data GeneralType a = + SingleType { + stType :: a + } | + TypeMerge { + tmMerge :: MergeType, + tmTypes :: [GeneralType a] + } + deriving (Eq,Ord) + +checkGeneralType :: (MergeableM m, Mergeable c) => (a -> b -> m c) -> GeneralType a -> GeneralType b -> m c +checkGeneralType f ti1 ti2 = singleCheck ti1 ti2 where + singleCheck (SingleType t1) (SingleType t2) = t1 `f` t2 + -- NOTE: The merge-alls must be expanded strictly before the merge-anys. + singleCheck ti1 (TypeMerge MergeIntersect t2) = mergeAllM $ map (ti1 `singleCheck`) t2 + singleCheck (TypeMerge MergeUnion t1) ti2 = mergeAllM $ map (`singleCheck` ti2) t1 + singleCheck (TypeMerge MergeIntersect t1) ti2 = mergeAnyM $ map (`singleCheck` ti2) t1 + singleCheck ti1 (TypeMerge MergeUnion t2) = mergeAnyM $ map (ti1 `singleCheck`) t2 diff --git a/src/Types/IntegrationTest.hs b/src/Types/IntegrationTest.hs new file mode 100644 --- /dev/null +++ b/src/Types/IntegrationTest.hs @@ -0,0 +1,96 @@ +{- ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Types.IntegrationTest ( + ExpectedResult(..), + IntegrationTest(..), + IntegrationTestHeader(..), + OutputPattern(..), + OutputScope(..), + getExcludePattern, + getRequirePattern, + isExpectCompileError, + isExpectRuntimeError, + isExpectRuntimeSuccess, +) where + +import Types.TypeCategory +import Types.DefinedCategory +import Types.Procedure (Expression) + + +data IntegrationTestHeader c = + IntegrationTestHeader { + ithContext :: [c], + ithTestName :: String, + ithResult :: ExpectedResult c + } + +data IntegrationTest c = + IntegrationTest { + itHeader :: IntegrationTestHeader c, + itCategory :: [AnyCategory c], + itDefinition :: [DefinedCategory c] + } + +data ExpectedResult c = + ExpectCompileError { + eceContext :: [c], + eceRequirePattern :: [OutputPattern], + eceExcludePattern :: [OutputPattern] + } | + ExpectRuntimeError { + ereContext :: [c], + ereExpression :: Expression c, + ereRequirePattern :: [OutputPattern], + ereExcludePattern :: [OutputPattern] + } | + ExpectRuntimeSuccess { + ersContext :: [c], + ersExpression :: Expression c, + ersRequirePattern :: [OutputPattern], + ersExcludePattern :: [OutputPattern] + } + +data OutputPattern = + OutputPattern { + opScope :: OutputScope, + opPattern :: String + } + deriving (Eq,Ord,Show) + +data OutputScope = OutputAny | OutputCompiler | OutputStderr | OutputStdout deriving (Eq,Ord,Show) + +isExpectCompileError (ExpectCompileError _ _ _) = True +isExpectCompileError _ = False + +isExpectRuntimeError (ExpectRuntimeError _ _ _ _) = True +isExpectRuntimeError _ = False + +isExpectRuntimeSuccess (ExpectRuntimeSuccess _ _ _ _) = True +isExpectRuntimeSuccess _ = False + +getRequirePattern (ExpectCompileError _ rs _) = rs +getRequirePattern (ExpectRuntimeError _ _ rs _) = rs +getRequirePattern (ExpectRuntimeSuccess _ _ rs _) = rs + +getExcludePattern (ExpectCompileError _ _ es) = es +getExcludePattern (ExpectRuntimeError _ _ _ es) = es +getExcludePattern (ExpectRuntimeSuccess _ _ _ es) = es diff --git a/src/Types/Positional.hs b/src/Types/Positional.hs new file mode 100644 --- /dev/null +++ b/src/Types/Positional.hs @@ -0,0 +1,58 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +module Types.Positional ( + Positional(..), + alwaysPair, + processPairs, + processPairsT, +) where + +import Control.Monad (Monad(..)) +import Control.Monad.Trans (MonadTrans(..)) + +import Base.CompileError + + +newtype Positional a = + Positional { + pValues :: [a] + } + deriving (Eq,Ord,Show) + +instance Functor Positional where + fmap f = Positional . fmap f . pValues + +alwaysPair :: Monad m => a -> b -> m (a,b) +alwaysPair x y = return (x,y) + +processPairs :: (Show a, Show b, CompileErrorM m) => + (a -> b -> m c) -> Positional a -> Positional b -> m [c] +processPairs f (Positional ps1) (Positional ps2) + | length ps1 == length ps2 = + collectAllOrErrorM $ map (uncurry f) (zip ps1 ps2) + | otherwise = + compileError $ "Parameter count mismatch: " ++ show ps1 ++ " vs. " ++ show ps2 + +processPairsT :: (MonadTrans t, Monad (t m), Show a, Show b, CompileErrorM m) => + (a -> b -> t m c) -> Positional a -> Positional b -> t m [c] +processPairsT f (Positional ps1) (Positional ps2) + | length ps1 == length ps2 = + sequence $ map (uncurry f) (zip ps1 ps2) + | otherwise = + lift $ compileError $ "Parameter count mismatch: " ++ show ps1 ++ " vs. " ++ show ps2 diff --git a/src/Types/Procedure.hs b/src/Types/Procedure.hs new file mode 100644 --- /dev/null +++ b/src/Types/Procedure.hs @@ -0,0 +1,254 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Types.Procedure ( + ArgValues(..), + Assignable(..), + ExecutableProcedure(..), + Expression(..), + ExpressionStart(..), + FunctionCall(..), + FunctionQualifier(..), + FunctionSpec(..), + IfElifElse(..), + InputValue(..), + Operator(..), + OutputValue(..), + Procedure(..), + ReturnValues(..), + ScopedBlock(..), + Statement(..), + ValueLiteral(..), + ValueOperation(..), + VariableName(..), + VoidExpression(..), + WhileLoop(..), + getExpressionContext, + getStatementContext, + isDiscardedInput, + isUnnamedReturns, +) where + +import Data.List (intercalate) + +import Types.Function +import Types.Positional +import Types.TypeCategory +import Types.TypeInstance + + +-- NOTE: Requires FunctionType and SymbolScope to compile, but those might not +-- be available when this needs to be parsed. +data ExecutableProcedure c = + ExecutableProcedure { + epContext :: [c], + epEnd :: [c], + epName :: FunctionName, + epArgs :: ArgValues c, + epReturns :: ReturnValues c, + epProcedure :: Procedure c + } + deriving (Show) -- TODO: Remove Show? Or add proper formatting. + +data ArgValues c = + ArgValues { + avContext :: [c], + avNames :: Positional (InputValue c) + } + +instance Show c => Show (ArgValues c) where + show (ArgValues c v) = + "(" ++ intercalate ",\n" (map show $ pValues v) ++ ")" ++ + " /*" ++ formatFullContext c ++ "*/" + +data ReturnValues c = + NamedReturns { + nrContext :: [c], + nrNames :: Positional (OutputValue c) + } | + UnnamedReturns { + urContext :: [c] + } + +isUnnamedReturns :: ReturnValues c -> Bool +isUnnamedReturns (UnnamedReturns _) = True +isUnnamedReturns _ = False + +instance Show c => Show (ReturnValues c) where + show (NamedReturns c v) = + "(" ++ intercalate ",\n" (map show $ pValues v) ++ ")" ++ + " /*" ++ formatFullContext c ++ "*/" + show (UnnamedReturns c) = "/*unnamed returns: " ++ formatFullContext c ++ "*/" + +data VariableName = + VariableName { + vnName :: String + } + deriving (Eq,Ord) + +instance Show VariableName where + show (VariableName n) = n + +data InputValue c = + InputValue { + ivContext :: [c], + ivName :: VariableName + } | + DiscardInput { + iiContext :: [c] + } + +isDiscardedInput :: InputValue c -> Bool +isDiscardedInput (DiscardInput _) = True +isDiscardedInput _ = False + +instance Show c => Show (InputValue c) where + show (InputValue c v) = show v ++ " /*" ++ formatFullContext c ++ "*/" + show (DiscardInput c) = "_" ++ " /*" ++ formatFullContext c ++ "*/" + +data OutputValue c = + OutputValue { + ovContext :: [c], + ovName :: VariableName + } + +instance Show c => Show (OutputValue c) where + show (OutputValue c v) = show v ++ " /*" ++ formatFullContext c ++ "*/" + + +data Procedure c = + Procedure [c] [Statement c] + deriving (Show) + +data Statement c = + EmptyReturn [c] | + ExplicitReturn [c] (Positional (Expression c)) | + LoopBreak [c] | + LoopContinue [c] | + FailCall [c] (Expression c) | + IgnoreValues [c] (Expression c) | + Assignment [c] (Positional (Assignable c)) (Expression c) | + NoValueExpression [c] (VoidExpression c) + deriving (Show) + +getStatementContext :: Statement c -> [c] +getStatementContext (EmptyReturn c) = c +getStatementContext (ExplicitReturn c _) = c +getStatementContext (LoopBreak c) = c +getStatementContext (LoopContinue c) = c +getStatementContext (FailCall c _) = c +getStatementContext (IgnoreValues c _) = c +getStatementContext (Assignment c _ _) = c +getStatementContext (NoValueExpression c _) = c + +data Assignable c = + CreateVariable [c] ValueType VariableName | + ExistingVariable (InputValue c) + deriving (Show) + +data VoidExpression c = + Conditional (IfElifElse c) | + Loop (WhileLoop c) | + WithScope (ScopedBlock c) | + Unconditional (Procedure c) | + LineComment String + deriving (Show) + +data IfElifElse c = + IfStatement [c] (Expression c) (Procedure c) (IfElifElse c) | + ElseStatement [c] (Procedure c) | + TerminateConditional + deriving (Show) + +data WhileLoop c = + WhileLoop [c] (Expression c) (Procedure c) (Maybe (Procedure c)) + deriving (Show) + +data ScopedBlock c = + ScopedBlock [c] (Procedure c) (Maybe (Procedure c)) (Statement c) + deriving (Show) + +data Expression c = + Expression [c] (ExpressionStart c) [ValueOperation c] | + Literal (ValueLiteral c) | + UnaryExpression [c] (Operator c) (Expression c) | + InfixExpression [c] (Expression c) (Operator c) (Expression c) | + InitializeValue [c] TypeInstance (Positional GeneralInstance) (Positional (Expression c)) + deriving (Show) + +data FunctionQualifier c = + CategoryFunction [c] CategoryName | + TypeFunction [c] TypeInstanceOrParam | + -- TODO: Does this need to allow conversion calls? + ValueFunction [c] (Expression c) | + UnqualifiedFunction + deriving (Show) + +data FunctionSpec c = + FunctionSpec [c] (FunctionQualifier c) FunctionName (Positional GeneralInstance) + deriving (Show) + +data Operator c = + NamedOperator String | + FunctionOperator [c] (FunctionSpec c) + deriving (Show) + +getExpressionContext :: Expression c -> [c] +getExpressionContext (Expression c _ _) = c +getExpressionContext (Literal l) = getValueLiteralContext l +getExpressionContext (UnaryExpression c _ _) = c +getExpressionContext (InfixExpression c _ _ _) = c +getExpressionContext (InitializeValue c _ _ _) = c + +data FunctionCall c = + FunctionCall [c] FunctionName (Positional GeneralInstance) (Positional (Expression c)) + deriving (Show) + +data ExpressionStart c = + NamedVariable (OutputValue c) | + CategoryCall [c] CategoryName (FunctionCall c) | + TypeCall [c] TypeInstanceOrParam (FunctionCall c) | + UnqualifiedCall [c] (FunctionCall c) | + BuiltinCall [c] (FunctionCall c) | + ParensExpression [c] (Expression c) | + InlineAssignment [c] VariableName (Expression c) + deriving (Show) + +data ValueLiteral c = + StringLiteral [c] String | + CharLiteral [c] Char | + IntegerLiteral [c] Bool Integer | + DecimalLiteral [c] Integer Integer | + BoolLiteral [c] Bool | + EmptyLiteral [c] + deriving (Show) + +getValueLiteralContext :: ValueLiteral c -> [c] +getValueLiteralContext (StringLiteral c _) = c +getValueLiteralContext (CharLiteral c _) = c +getValueLiteralContext (IntegerLiteral c _ _) = c +getValueLiteralContext (DecimalLiteral c _ _) = c +getValueLiteralContext (BoolLiteral c _) = c +getValueLiteralContext (EmptyLiteral c) = c + +data ValueOperation c = + ConvertedCall [c] TypeInstance (FunctionCall c) | + ValueCall [c] (FunctionCall c) + deriving (Show) diff --git a/src/Types/TypeCategory.hs b/src/Types/TypeCategory.hs new file mode 100644 --- /dev/null +++ b/src/Types/TypeCategory.hs @@ -0,0 +1,960 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Types.TypeCategory ( + AnyCategory(..), + CategoryMap(..), + CategoryResolver(..), + FunctionName(..), + Namespace(..), + ParamFilter(..), + PassedValue(..), + ScopedFunction(..), + SymbolScope(..), + ValueDefine(..), + ValueParam(..), + ValueRefine(..), + checkCategoryInstances, + checkConnectedTypes, + checkConnectionCycles, + checkParamVariances, + declareAllTypes, -- TODO: Remove? + flattenAllConnections, + formatFullContext, + formatFullContextBrace, + getCategory, + getCategoryContext, + getCategoryDefines, + getCategoryDeps, + getCategoryFilterMap, + getCategoryFilters, + getCategoryFunctions, + getCategoryName, + getCategoryNamespace, + getCategoryParams, + getCategoryRefines, + getConcreteCategory, + getFilterMap, + getFunctionFilterMap, + getInstanceCategory, + getValueCategory, + includeNewTypes, + isInstanceInterface, + isDynamicNamespace, + isNoNamespace, + isStaticNamespace, + isValueConcrete, + isValueInterface, + mergeDefines, + mergeFunctions, + mergeRefines, + noDuplicateDefines, + noDuplicateRefines, + parsedToFunctionType, + partitionByScope, + setCategoryNamespace, + topoSortCategories, + uncheckedSubFunction, + validateCategoryFunction, +) where + +import Control.Arrow (second) +import Control.Monad (when) +import Data.List (group,groupBy,intercalate,sort,sortBy) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Base.CompileError +import Base.Mergeable +import Types.Function +import Types.GeneralType +import Types.Positional +import Types.TypeInstance +import Types.Variance + + +data AnyCategory c = + ValueInterface { + viContext :: [c], + viNamespace :: Namespace, + viName :: CategoryName, + viParams :: [ValueParam c], + viRefines :: [ValueRefine c], + viParamFilter :: [ParamFilter c], + viFunctions :: [ScopedFunction c] + } | + InstanceInterface { + iiContext :: [c], + iiNamespace :: Namespace, + iiName :: CategoryName, + iiParams :: [ValueParam c], + iiParamFilter :: [ParamFilter c], + iiFunctions :: [ScopedFunction c] + } | + ValueConcrete { + vcContext :: [c], + vcNamespace :: Namespace, + vcName :: CategoryName, + vcParams :: [ValueParam c], + vcRefines :: [ValueRefine c], + vcDefines :: [ValueDefine c], + vcParamFilter :: [ParamFilter c], + vcFunctions :: [ScopedFunction c] + } + +formatFullContext :: Show a => [a] -> String +formatFullContext cs = intercalate " -> " (map show cs) + +formatFullContextBrace :: Show a => [a] -> String +formatFullContextBrace [] = "" +formatFullContextBrace cs = " [" ++ intercalate " -> " (map show cs) ++ "]" + +instance Show c => Show (AnyCategory c) where + show = format where + format (ValueInterface cs ns n ps rs vs fs) = + "@value interface " ++ show n ++ formatParams ps ++ namespace ns ++ " { " ++ formatContext cs ++ "\n" ++ + (intercalate "\n\n" $ + map (\r -> " " ++ formatRefine r) rs ++ + map (\v -> " " ++ formatValue v) vs ++ + map (\f -> formatInterfaceFunc f) fs) ++ + "\n}\n" + format (InstanceInterface cs ns n ps vs fs) = + "@type interface " ++ show n ++ formatParams ps ++ namespace ns ++ " { " ++ formatContext cs ++ + (intercalate "\n\n" $ + map (\v -> " " ++ formatValue v) vs ++ + map (\f -> formatInterfaceFunc f) fs) ++ + "\n}\n" + format (ValueConcrete cs ns n ps rs ds vs fs) = + "concrete " ++ show n ++ formatParams ps ++ namespace ns ++ " { " ++ formatContext cs ++ "\n" ++ + (intercalate "\n\n" $ + map (\r -> " " ++ formatRefine r) rs ++ + map (\d -> " " ++ formatDefine d) ds ++ + map (\v -> " " ++ formatValue v) vs ++ + map (\f -> formatInterfaceFunc f) fs) ++ + "\n}\n" + namespace ns + | isStaticNamespace ns = " /*" ++ show ns ++ "*/" + | otherwise = "" + formatContext cs = "/*" ++ formatFullContext cs ++ "*/" + formatParams ps = let (con,inv,cov) = (foldr partitionParam ([],[],[]) ps) in + "<" ++ intercalate "," con ++ "|" ++ + intercalate "," inv ++ "|" ++ + intercalate "," cov ++ ">" + -- NOTE: This assumes that the params are ordered by contravariant, + -- invariant, and covariant. + partitionParam p (con,inv,cov) + | vpVariance p == Contravariant = ((show $ vpParam p):con,inv,cov) + | vpVariance p == Invariant = (con,(show $ vpParam p):inv,cov) + | vpVariance p == Covariant = (con,inv,(show $ vpParam p):cov) + formatRefine r = "refines " ++ show (vrType r) ++ " " ++ formatContext (vrContext r) + formatDefine d = "defines " ++ show (vdType d) ++ " " ++ formatContext (vdContext d) + formatValue v = show (pfParam v) ++ " " ++ show (pfFilter v) ++ + " " ++ formatContext (pfContext v) + formatInterfaceFunc f = showFunctionInContext "" " " f + formatConcreteFunc f = showFunctionInContext (showScope (sfScope f) ++ " ") " " f + +showScope :: SymbolScope -> String +showScope CategoryScope = "@category" +showScope TypeScope = "@type" +showScope ValueScope = "@value" +showScope LocalScope = "@local" + +getCategoryName :: AnyCategory c -> CategoryName +getCategoryName (ValueInterface _ _ n _ _ _ _) = n +getCategoryName (InstanceInterface _ _ n _ _ _) = n +getCategoryName (ValueConcrete _ _ n _ _ _ _ _) = n + +getCategoryContext :: AnyCategory c -> [c] +getCategoryContext (ValueInterface c _ _ _ _ _ _) = c +getCategoryContext (InstanceInterface c _ _ _ _ _) = c +getCategoryContext (ValueConcrete c _ _ _ _ _ _ _) = c + +getCategoryNamespace :: AnyCategory c -> Namespace +getCategoryNamespace (ValueInterface _ ns _ _ _ _ _) = ns +getCategoryNamespace (InstanceInterface _ ns _ _ _ _) = ns +getCategoryNamespace (ValueConcrete _ ns _ _ _ _ _ _) = ns + +setCategoryNamespace :: Namespace -> AnyCategory c -> AnyCategory c +setCategoryNamespace ns (ValueInterface c _ n ps rs vs fs) = (ValueInterface c ns n ps rs vs fs) +setCategoryNamespace ns (InstanceInterface c _ n ps vs fs) = (InstanceInterface c ns n ps vs fs) +setCategoryNamespace ns (ValueConcrete c _ n ps rs ds vs fs) = (ValueConcrete c ns n ps rs ds vs fs) + +getCategoryParams :: AnyCategory c -> [ValueParam c] +getCategoryParams (ValueInterface _ _ _ ps _ _ _) = ps +getCategoryParams (InstanceInterface _ _ _ ps _ _) = ps +getCategoryParams (ValueConcrete _ _ _ ps _ _ _ _) = ps + +getCategoryRefines :: AnyCategory c -> [ValueRefine c] +getCategoryRefines (ValueInterface _ _ _ _ rs _ _) = rs +getCategoryRefines (InstanceInterface _ _ _ _ _ _) = [] +getCategoryRefines (ValueConcrete _ _ _ _ rs _ _ _) = rs + +getCategoryDefines :: AnyCategory c -> [ValueDefine c] +getCategoryDefines (ValueInterface _ _ _ _ _ _ _) = [] +getCategoryDefines (InstanceInterface _ _ _ _ _ _) = [] +getCategoryDefines (ValueConcrete _ _ _ _ _ ds _ _) = ds + +getCategoryFilters :: AnyCategory c -> [ParamFilter c] +getCategoryFilters (ValueInterface _ _ _ _ _ vs _) = vs +getCategoryFilters (InstanceInterface _ _ _ _ vs _) = vs +getCategoryFilters (ValueConcrete _ _ _ _ _ _ vs _) = vs + +getCategoryFunctions :: AnyCategory c -> [ScopedFunction c] +getCategoryFunctions (ValueInterface _ _ _ _ _ _ fs) = fs +getCategoryFunctions (InstanceInterface _ _ _ _ _ fs) = fs +getCategoryFunctions (ValueConcrete _ _ _ _ _ _ _ fs) = fs + +getCategoryDeps :: AnyCategory c -> Set.Set CategoryName +getCategoryDeps t = Set.fromList $ filter (/= getCategoryName t) $ refines ++ defines ++ filters ++ functions where + refines = concat $ map (fromInstance . SingleType . JustTypeInstance . vrType) $ getCategoryRefines t + defines = concat $ map (fromDefine . vdType) $ getCategoryDefines t + filters = concat $ map (fromFilter . pfFilter) $ getCategoryFilters t + functions = concat $ map fromFunction $ getCategoryFunctions t + fromInstance (TypeMerge _ ps) = concat $ map fromInstance ps + fromInstance (SingleType (JustTypeInstance (TypeInstance n ps))) = n:(concat $ map fromInstance $ pValues ps) + fromInstance _ = [] + fromDefine (DefinesInstance n ps) = n:(concat $ map fromInstance $ pValues ps) + fromFilter (TypeFilter _ t2@(JustTypeInstance _)) = fromInstance (SingleType t2) + fromFilter (DefinesFilter t2) = fromDefine t2 + fromType (ValueType _ t2) = fromInstance t2 + fromFunction f = args ++ returns ++ filters where + args = concat $ map (fromType . pvType) $ pValues $ sfArgs f + returns = concat $ map (fromType . pvType) $ pValues $ sfReturns f + filters = concat $ map (fromFilter . pfFilter) $ sfFilters f + +isValueInterface :: AnyCategory c -> Bool +isValueInterface (ValueInterface _ _ _ _ _ _ _) = True +isValueInterface _ = False + +isInstanceInterface :: AnyCategory c -> Bool +isInstanceInterface (InstanceInterface _ _ _ _ _ _) = True +isInstanceInterface _ = False + +isValueConcrete :: AnyCategory c -> Bool +isValueConcrete (ValueConcrete _ _ _ _ _ _ _ _) = True +isValueConcrete _ = False + +data Namespace = + StaticNamespace { + snName :: String + } | + NoNamespace | + DynamicNamespace + deriving (Eq,Ord) + +instance Show Namespace where + show (StaticNamespace n) = n + show _ = "" + +isStaticNamespace (StaticNamespace _) = True +isStaticNamespace _ = False + +isNoNamespace NoNamespace = True +isNoNamespace _ = False + +isDynamicNamespace DynamicNamespace = True +isDynamicNamespace _ = False + +data ValueRefine c = + ValueRefine { + vrContext :: [c], + vrType :: TypeInstance + } + +instance Show c => Show (ValueRefine c) where + show (ValueRefine c t) = show t ++ formatFullContextBrace c + +data ValueDefine c = + ValueDefine { + vdContext :: [c], + vdType :: DefinesInstance + } + +instance Show c => Show (ValueDefine c) where + show (ValueDefine c t) = show t ++ formatFullContextBrace c + +data ValueParam c = + ValueParam { + vpContext :: [c], + vpParam :: ParamName, + vpVariance :: Variance + } + +instance Show c => Show (ValueParam c) where + show (ValueParam c t v) = show t ++ " (" ++ show v ++ ")" ++ formatFullContextBrace c + +data ParamFilter c = + ParamFilter { + pfContext :: [c], + pfParam :: ParamName, + pfFilter :: TypeFilter + } + +instance Show c => Show (ParamFilter c) where + show (ParamFilter c n f) = show n ++ " " ++ show f ++ formatFullContextBrace c + +newtype CategoryResolver c = + CategoryResolver { + crCategories :: CategoryMap c + } + +instance (Show c) => TypeResolver (CategoryResolver c) where + trRefines (CategoryResolver tm) (TypeInstance n1 ps1) n2 + | n1 == n2 = do + (_,t) <- getValueCategory tm ([],n1) + processPairs alwaysPair (Positional $ map vpParam $ getCategoryParams t) ps1 + return ps1 + | otherwise = do + (_,t) <- getValueCategory tm ([],n1) + let params = map vpParam $ getCategoryParams t + assigned <- fmap Map.fromList $ processPairs alwaysPair (Positional params) ps1 + let pa = Map.fromList $ map (\r -> (tiName r,tiParams r)) $ map vrType $ getCategoryRefines t + ps2 <- case n2 `Map.lookup` pa of + (Just x) -> return x + _ -> compileError $ "Category " ++ show n1 ++ " does not refine " ++ show n2 + fmap Positional $ collectAllOrErrorM $ map (subAllParams assigned) $ pValues ps2 + trDefines (CategoryResolver tm) (TypeInstance n1 ps1) n2 = do + (_,t) <- getValueCategory tm ([],n1) + let params = map vpParam $ getCategoryParams t + assigned <- fmap Map.fromList $ processPairs alwaysPair (Positional params) ps1 + let pa = Map.fromList $ map (\r -> (diName r,diParams r)) $ map vdType $ getCategoryDefines t + ps2 <- case n2 `Map.lookup` pa of + (Just x) -> return x + _ -> compileError $ "Category " ++ show n1 ++ " does not define " ++ show n2 + fmap Positional $ collectAllOrErrorM $ map (subAllParams assigned) $ pValues ps2 + trVariance (CategoryResolver tm) n = do + (_,t) <- getCategory tm ([],n) + return $ Positional $ map vpVariance $ getCategoryParams t + trTypeFilters (CategoryResolver tm) (TypeInstance n ps) = do + (_,t) <- getValueCategory tm ([],n) + checkFilters t ps + trDefinesFilters (CategoryResolver tm) (DefinesInstance n ps) = do + (_,t) <- getInstanceCategory tm ([],n) + checkFilters t ps + trConcrete (CategoryResolver tm) n = do + (_,t) <- getCategory tm ([],n) + return (isValueConcrete t) + +data SymbolScope = + LocalScope | + CategoryScope | + TypeScope | + ValueScope + deriving (Eq,Ord,Show) + +partitionByScope :: (a -> SymbolScope) -> [a] -> ([a],[a],[a]) +partitionByScope f = foldr bin empty where + empty = ([],[],[]) + bin x (cs,ts,vs) + | f x == CategoryScope = (x:cs,ts,vs) + | f x == TypeScope = (cs,x:ts,vs) + | f x == ValueScope = (cs,ts,x:vs) + | otherwise = (cs,ts,vs) + +checkFilters :: (CompileErrorM m, MergeableM m) => + AnyCategory c -> Positional GeneralInstance -> m (Positional [TypeFilter]) +checkFilters t ps = do + let params = map vpParam $ getCategoryParams t + assigned <- fmap Map.fromList $ processPairs alwaysPair (Positional params) ps + fs <- collectAllOrErrorM $ map (subSingleFilter assigned . \f -> (pfParam f,pfFilter f)) + (getCategoryFilters t) + let fa = Map.fromListWith (++) $ map (second (:[])) fs + fmap Positional $ collectAllOrErrorM $ map (assignFilter fa) params where + subSingleFilter pa (n,(TypeFilter v t)) = do + (SingleType t2) <- uncheckedSubInstance (getValueForParam pa) (SingleType t) + return (n,(TypeFilter v t2)) + subSingleFilter pa (n,(DefinesFilter (DefinesInstance n2 ps))) = do + ps2 <- collectAllOrErrorM $ map (uncheckedSubInstance $ getValueForParam pa) (pValues ps) + return (n,(DefinesFilter (DefinesInstance n2 (Positional ps2)))) + assignFilter fa n = + case n `Map.lookup` fa of + (Just x) -> return x + _ -> return [] + +subAllParams :: (MergeableM m, CompileErrorM m) => + Map.Map ParamName GeneralInstance -> GeneralInstance -> m GeneralInstance +subAllParams pa = uncheckedSubInstance (getValueForParam pa) + +type CategoryMap c = Map.Map CategoryName (AnyCategory c) + +getCategory :: (Show c, CompileErrorM m) => + CategoryMap c -> ([c],CategoryName) -> m ([c],AnyCategory c) +getCategory tm (c,n) = + case n `Map.lookup` tm of + (Just t) -> return (c,t) + _ -> compileError $ "Type " ++ show n ++ context ++ " not found" + where + context + | null c = "" + | otherwise = formatFullContextBrace c + +getValueCategory :: (Show c, CompileErrorM m) => + CategoryMap c -> ([c],CategoryName) -> m ([c],AnyCategory c) +getValueCategory tm (c,n) = do + (c2,t) <- getCategory tm (c,n) + if isValueInterface t || isValueConcrete t + then return (c2,t) + else compileError $ "Category " ++ show n ++ + " cannot be used as a value" ++ + formatFullContextBrace c + +getInstanceCategory :: (Show c, CompileErrorM m) => + CategoryMap c -> ([c],CategoryName) -> m ([c],AnyCategory c) +getInstanceCategory tm (c,n) = do + (c2,t) <- getCategory tm (c,n) + if isInstanceInterface t + then return (c2,t) + else compileError $ "Category " ++ show n ++ + " cannot be used as a type interface" ++ + formatFullContextBrace c + +getConcreteCategory :: (Show c, CompileErrorM m) => + CategoryMap c -> ([c],CategoryName) -> m ([c],AnyCategory c) +getConcreteCategory tm (c,n) = do + (c2,t) <- getCategory tm (c,n) + if isValueConcrete t + then return (c2,t) + else compileError $ "Category " ++ show n ++ + " cannot be used as concrete" ++ + formatFullContextBrace c + +includeNewTypes :: (Show c, MergeableM m, CompileErrorM m) => + CategoryMap c -> [AnyCategory c] -> m (CategoryMap c) +includeNewTypes tm0 ts = do + checkConnectionCycles tm0 ts + checkConnectedTypes tm0 ts + checkParamVariances tm0 ts + ts <- topoSortCategories tm0 ts + ts <- flattenAllConnections tm0 ts + checkCategoryInstances tm0 ts + declareAllTypes tm0 ts + +declareAllTypes :: (Show c, CompileErrorM m) => + CategoryMap c -> [AnyCategory c] -> m (CategoryMap c) +declareAllTypes tm0 = foldr (\t tm -> tm >>= update t) (return tm0) where + update t tm = + case getCategoryName t `Map.lookup` tm of + (Just t2) -> compileError $ "Type " ++ show (getCategoryName t) ++ + formatFullContextBrace (getCategoryContext t) ++ + " has already been declared" ++ + showExisting t2 + _ -> return $ Map.insert (getCategoryName t) t tm + showExisting t + | isBuiltinCategory (getCategoryName t) = " [builtin type]" + | otherwise = formatFullContextBrace (getCategoryContext t) + +getFilterMap :: [ValueParam c] -> [ParamFilter c] -> ParamFilters +getFilterMap ps fs = getFilters $ zip (Set.toList pa) (repeat []) where + pa = Set.fromList $ map vpParam ps + getFilters pa0 = let fs' = map (\f -> (pfParam f,pfFilter f)) fs in + Map.fromListWith (++) $ map (second (:[])) fs' ++ pa0 + +getCategoryFilterMap :: AnyCategory c -> ParamFilters +getCategoryFilterMap t = getFilterMap (getCategoryParams t) (getCategoryFilters t) + +-- TODO: Use this where it's needed in this file. +getFunctionFilterMap :: ScopedFunction c -> ParamFilters +getFunctionFilterMap f = getFilterMap (pValues $ sfParams f) (sfFilters f) + +checkConnectedTypes :: (Show c, MergeableM m, CompileErrorM m) => + CategoryMap c -> [AnyCategory c] -> m () +checkConnectedTypes tm0 ts = do + tm <- declareAllTypes tm0 ts + mergeAllM (map (checkSingle tm) ts) + where + checkSingle tm (ValueInterface c _ n _ rs _ _) = do + let ts = map (\r -> (vrContext r,tiName $ vrType r)) rs + is <- collectAllOrErrorM $ map (getCategory tm) ts + mergeAllM (map (valueRefinesInstanceError c n) is) + mergeAllM (map (valueRefinesConcreteError c n) is) + checkSingle tm (ValueConcrete c _ n _ rs ds _ _) = do + let ts1 = map (\r -> (vrContext r,tiName $ vrType r)) rs + let ts2 = map (\d -> (vdContext d,diName $ vdType d)) ds + is1 <- collectAllOrErrorM $ map (getCategory tm) ts1 + is2 <- collectAllOrErrorM $ map (getCategory tm) ts2 + mergeAllM (map (concreteRefinesInstanceError c n) is1) + mergeAllM (map (concreteDefinesValueError c n) is2) + mergeAllM (map (concreteRefinesConcreteError c n) is1) + mergeAllM (map (concreteDefinesConcreteError c n) is2) + checkSingle _ _ = return () + valueRefinesInstanceError c n (c2,t) + | isInstanceInterface t = + compileError $ "Value interface " ++ show n ++ formatFullContextBrace c ++ + " cannot refine type interface " ++ + show (iiName t) ++ formatFullContextBrace c2 + | otherwise = return () + valueRefinesConcreteError c n (c2,t) + | isValueConcrete t = + compileError $ "Value interface " ++ show n ++ formatFullContextBrace c ++ + " cannot refine concrete type " ++ + show (getCategoryName t) ++ formatFullContextBrace c2 + | otherwise = return () + concreteRefinesInstanceError c n (c2,t) + | isInstanceInterface t = + compileError $ "Concrete type " ++ show n ++ formatFullContextBrace c ++ + " cannot refine instance interface " ++ + show (getCategoryName t) ++ formatFullContextBrace c2 ++ + " => use defines instead" + | otherwise = return () + concreteDefinesValueError c n (c2,t) + | isValueInterface t = + compileError $ "Concrete type " ++ show n ++ formatFullContextBrace c ++ + " cannot define value interface " ++ + show (getCategoryName t) ++ formatFullContextBrace c2 ++ + " => use refines instead" + | otherwise = return () + concreteRefinesConcreteError c n (c2,t) + | isValueConcrete t = + compileError $ "Concrete type " ++ show n ++ formatFullContextBrace c ++ + " cannot refine concrete type " ++ + show (getCategoryName t) ++ formatFullContextBrace c2 + | otherwise = return () + concreteDefinesConcreteError c n (c2,t) + | isValueConcrete t = + compileError $ "Concrete type " ++ show n ++ formatFullContextBrace c ++ + " cannot define concrete type " ++ + show (getCategoryName t) ++ formatFullContextBrace c2 + | otherwise = return () + +checkConnectionCycles :: (Show c, MergeableM m, CompileErrorM m) => + CategoryMap c -> [AnyCategory c] -> m () +checkConnectionCycles tm0 ts = mergeAllM (map (checker []) ts) where + tm = Map.union tm0 $ Map.fromList $ zip (map getCategoryName ts) ts + checker us (ValueInterface c _ n _ rs _ _) = do + failIfCycle n c us + let ts = map (\r -> (vrContext r,tiName $ vrType r)) rs + is <- collectAllOrErrorM $ map (getValueCategory tm) ts + mergeAllM (map (checker (us ++ [n]) . snd) is) + checker us (ValueConcrete c _ n _ rs _ _ _) = do + failIfCycle n c us + let ts = map (\r -> (vrContext r,tiName $ vrType r)) rs + is <- collectAllOrErrorM $ map (getValueCategory tm) ts + mergeAllM (map (checker (us ++ [n]) . snd) is) + checker _ _ = return () + failIfCycle n c us = + when (n `Set.member` (Set.fromList us)) $ + compileError $ "Category " ++ show n ++ formatFullContextBrace c ++ + " refers back to itself: " ++ + intercalate " -> " (map show (us ++ [n])) + +checkParamVariances :: (Show c, MergeableM m, CompileErrorM m) => + CategoryMap c -> [AnyCategory c] -> m () +checkParamVariances tm0 ts = do + tm <- declareAllTypes tm0 ts + let r = CategoryResolver tm + mergeAllM (map (checkCategory r) ts) + where + checkCategory r (ValueInterface c _ n ps rs fa _) = do + noDuplicates c n ps + let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) ps + mergeAllM (map (checkRefine r vm) rs) + mergeAllM $ map (checkFilterVariance r vm) fa + checkCategory r (ValueConcrete c _ n ps rs ds fa _) = do + noDuplicates c n ps + let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) ps + mergeAllM (map (checkRefine r vm) rs) + mergeAllM (map (checkDefine r vm) ds) + mergeAllM $ map (checkFilterVariance r vm) fa + checkCategory r (InstanceInterface c _ n ps fa _) = do + noDuplicates c n ps + let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) ps + mergeAllM $ map (checkFilterVariance r vm) fa + noDuplicates c n ps = mergeAllM (map checkCount $ group $ sort $ map vpParam ps) where + checkCount xa@(x:_:_) = + compileError $ "Param " ++ show x ++ " occurs " ++ show (length xa) ++ + " times in " ++ show n ++ formatFullContextBrace c + checkCount _ = return () + checkRefine r vm (ValueRefine c t) = + validateInstanceVariance r vm Covariant (SingleType $ JustTypeInstance t) `reviseError` + (show t ++ formatFullContextBrace c) + checkDefine r vm (ValueDefine c t) = + validateDefinesVariance r vm Covariant t `reviseError` + (show t ++ formatFullContextBrace c) + checkFilterVariance r vs (ParamFilter c n f@(TypeFilter FilterRequires t)) = + flip reviseError ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) $ do + case n `Map.lookup` vs of + Just Contravariant -> compileError $ "Contravariant param " ++ show n ++ + " cannot have a requires filter" + Nothing -> compileError $ "Param " ++ show n ++ " is undefined" + _ -> return () + validateInstanceVariance r vs Contravariant (SingleType t) + checkFilterVariance r vs (ParamFilter c n f@(TypeFilter FilterAllows t)) = + flip reviseError ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) $ do + case n `Map.lookup` vs of + Just Covariant -> compileError $ "Covariant param " ++ show n ++ + " cannot have an allows filter" + Nothing -> compileError $ "Param " ++ show n ++ " is undefined" + _ -> return () + validateInstanceVariance r vs Covariant (SingleType t) + checkFilterVariance r vs (ParamFilter c n f@(DefinesFilter t)) = + flip reviseError ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) $ do + case n `Map.lookup` vs of + Just Contravariant -> compileError $ "Contravariant param " ++ show n ++ + " cannot have a defines filter" + Nothing -> compileError $ "Param " ++ show n ++ " is undefined" + _ -> return () + validateDefinesVariance r vs Contravariant t + +checkCategoryInstances :: (Show c, MergeableM m, CompileErrorM m) => + CategoryMap c -> [AnyCategory c] -> m () +checkCategoryInstances tm0 ts = do + tm <- declareAllTypes tm0 ts + let r = CategoryResolver tm + mergeAllM $ map (checkSingle r) ts + where + checkSingle r t = do + let pa = Set.fromList $ map vpParam $ getCategoryParams t + let fm = getCategoryFilterMap t + let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t + mergeAllM $ map (checkFilterParam pa) (getCategoryFilters t) + mergeAllM $ map (checkRefine r fm) (getCategoryRefines t) + mergeAllM $ map (checkDefine r fm) (getCategoryDefines t) + mergeAllM $ map (checkFilter r fm) (getCategoryFilters t) + mergeAllM $ map (validateCategoryFunction r t) (getCategoryFunctions t) + checkFilterParam pa (ParamFilter c n _) = + when (not $ n `Set.member` pa) $ + compileError $ "Param " ++ show n ++ formatFullContextBrace c ++ " does not exist" + checkRefine r fm (ValueRefine c t) = + validateTypeInstance r fm t `reviseError` + (show t ++ formatFullContextBrace c) + checkDefine r fm (ValueDefine c t) = + validateDefinesInstance r fm t `reviseError` + (show t ++ formatFullContextBrace c) + checkFilter r fm (ParamFilter c n f) = + validateTypeFilter r fm f `reviseError` + (show n ++ " " ++ show f ++ formatFullContextBrace c) + +validateCategoryFunction :: (Show c, MergeableM m, CompileErrorM m, TypeResolver r) => + r -> AnyCategory c -> ScopedFunction c -> m () +validateCategoryFunction r t f = do + let fm = getCategoryFilterMap t + let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t + flip reviseError ("In function:\n---\n" ++ show f ++ "\n---\n") $ do + funcType <- parsedToFunctionType f + case sfScope f of + CategoryScope -> validatateFunctionType r Map.empty Map.empty funcType + TypeScope -> validatateFunctionType r fm vm funcType + ValueScope -> validatateFunctionType r fm vm funcType + +topoSortCategories :: (Show c, MergeableM m, CompileErrorM m) => + CategoryMap c -> [AnyCategory c] -> m [AnyCategory c] +topoSortCategories tm0 ts = do + tm <- declareAllTypes tm0 ts + (ts',_) <- foldr (update tm) (return ([],Map.keysSet tm0)) ts + return ts' + where + update tm t u = do + (ts,ta) <- u + if getCategoryName t `Set.member` ta + then return (ts,ta) + else do + refines <- collectAllOrErrorM $ + map (\r -> getCategory tm (vrContext r,tiName $ vrType r)) $ getCategoryRefines t + defines <- collectAllOrErrorM $ + map (\d -> getCategory tm (vdContext d,diName $ vdType d)) $ getCategoryDefines t + (ts',ta') <- foldr (update tm) u (map snd $ refines ++ defines) + let ts'' = ts' ++ [t] + let ta'' = Set.insert (getCategoryName t) ta' + return (ts'',ta'') + +mergeObjects :: (MergeableM m, CompileErrorM m) => + (a -> a -> m ()) -> [a] -> m [a] +mergeObjects f = return . merge [] where + merge cs [] = cs + merge cs (x:xs) = merge (cs ++ ys) xs where + -- TODO: Should f just perform merging? In case we want to preserve info + -- about what was merged, e.g., return m [(p,a)]. + checker x2 = f x2 x + ys = if isCompileError $ mergeAnyM (map checker (cs ++ xs)) + then [x] -- x is not redundant => keep. + else [] -- x is redundant => remove. + +mergeRefines :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> [ValueRefine c] -> m [ValueRefine c] +mergeRefines r f = mergeObjects check where + check (ValueRefine _ t1@(TypeInstance n1 _)) (ValueRefine _ t2@(TypeInstance n2 _)) + | n1 /= n2 = compileError $ show t1 ++ " and " ++ show t2 ++ " are incompatible" + | otherwise = do + checkGeneralMatch r f Covariant (SingleType $ JustTypeInstance $ t1) + (SingleType $ JustTypeInstance $ t2) + +mergeDefines :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> [ValueDefine c] -> m [ValueDefine c] +mergeDefines r f = mergeObjects check where + check (ValueDefine _ t1@(DefinesInstance n1 _)) (ValueDefine _ t2@(DefinesInstance n2 _)) + | n1 /= n2 = compileError $ show t1 ++ " and " ++ show t2 ++ " are incompatible" + | otherwise = do + checkDefinesMatch r f t1 t2 + return () + +noDuplicateRefines :: (Show c, MergeableM m, CompileErrorM m) => + [c] -> CategoryName -> [ValueRefine c] -> m () +noDuplicateRefines c n rs = do + let names = map (\r -> (tiName $ vrType r,r)) rs + noDuplicates c n names + +noDuplicateDefines :: (Show c, MergeableM m, CompileErrorM m) => + [c] -> CategoryName -> [ValueDefine c] -> m () +noDuplicateDefines c n ds = do + let names = map (\d -> (diName $ vdType d,d)) ds + noDuplicates c n names + +noDuplicates :: (Show c, Show a, MergeableM m, CompileErrorM m) => + [c] -> CategoryName -> [(CategoryName,a)] -> m () +noDuplicates c n ns = + mergeAllM $ map checkCount $ groupBy (\x y -> fst x == fst y) $ + sortBy (\x y -> fst x `compare` fst y) ns where + checkCount xa@(x:_:_) = + compileError $ "Category " ++ show (fst x) ++ " occurs " ++ show (length xa) ++ + " times in " ++ show n ++ formatFullContextBrace c ++ " :\n---\n" ++ + intercalate "\n---\n" (map (show . snd) xa) + checkCount _ = return () + +flattenAllConnections :: (Show c, MergeableM m, CompileErrorM m) => + CategoryMap c -> [AnyCategory c] -> m [AnyCategory c] +flattenAllConnections tm0 ts = do + -- We need to process all refines before type-checking can be done. + tm1 <- foldr preMerge (return tm0) (reverse ts) + let r = CategoryResolver tm1 + (ts',_) <- foldr (update r) (return ([],tm0)) (reverse ts) + return ts' + where + preMerge t u = do + tm <- u + t' <- preMergeSingle tm t + return $ Map.insert (getCategoryName t') t' tm + preMergeSingle tm t@(ValueInterface c ns n ps rs vs fs) = do + rs' <- fmap concat $ collectAllOrErrorM $ map (getRefines tm) rs + return $ ValueInterface c ns n ps rs' vs fs + preMergeSingle tm t@(ValueConcrete c ns n ps rs ds vs fs) = do + rs' <- fmap concat $ collectAllOrErrorM $ map (getRefines tm) rs + return $ ValueConcrete c ns n ps rs' ds vs fs + preMergeSingle _ t = return t + update r t u = do + (ts,tm) <- u + t' <- updateSingle r tm t `reviseError` + ("In category " ++ show (getCategoryName t) ++ + formatFullContextBrace (getCategoryContext t)) + return (ts ++ [t'],Map.insert (getCategoryName t') t' tm) + updateSingle r tm t@(ValueInterface c ns n ps rs vs fs) = do + let fm = getCategoryFilterMap t + rs' <- fmap concat $ collectAllOrErrorM $ map (getRefines tm) rs + rs'' <- mergeRefines r fm rs' + noDuplicateRefines c n rs'' + checkMerged r fm rs rs'' + -- Only merge from direct parents. + fs' <- mergeFunctions r tm fm rs [] fs + return $ ValueInterface c ns n ps rs'' vs fs' + -- TODO: Remove duplication below and/or have separate tests. + updateSingle r tm t@(ValueConcrete c ns n ps rs ds vs fs) = do + let fm = getCategoryFilterMap t + rs' <- fmap concat $ collectAllOrErrorM $ map (getRefines tm) rs + rs'' <- mergeRefines r fm rs' + noDuplicateRefines c n rs'' + checkMerged r fm rs rs'' + ds' <- mergeDefines r fm ds + noDuplicateDefines c n ds' + -- Only merge from direct parents. + fs' <- mergeFunctions r tm fm rs ds fs + return $ ValueConcrete c ns n ps rs'' ds' vs fs' + updateSingle _ _ t = return t + getRefines tm ra@(ValueRefine c t@(TypeInstance n ps)) = do + (_,v) <- getValueCategory tm (c,n) + let refines = getCategoryRefines v + pa <- assignParams tm c t + fmap (ra:) $ collectAllOrErrorM $ map (subAll c pa) refines + subAll c pa (ValueRefine c1 t1) = do + (SingleType (JustTypeInstance t2)) <- + uncheckedSubInstance (getValueForParam pa) (SingleType (JustTypeInstance t1)) + return $ ValueRefine (c ++ c1) t2 + assignParams tm c (TypeInstance n ps) = do + (_,v) <- getValueCategory tm (c,n) + let ns = map vpParam $ getCategoryParams v + paired <- processPairs alwaysPair (Positional ns) ps + return $ Map.fromList paired + checkMerged r fm rs rs2 = do + let rm = Map.fromList $ map (\t -> (tiName $ vrType t,t)) rs + mergeAllM $ map (\t -> checkConvert r fm (tiName (vrType t) `Map.lookup` rm) t) rs2 + checkConvert r fm (Just ta1@(ValueRefine _ t1)) ta2@(ValueRefine _ t2) = do + checkGeneralMatch r fm Covariant (SingleType $ JustTypeInstance t1) + (SingleType $ JustTypeInstance t2) `reviseError` + ("Cannot refine " ++ show ta1 ++ " from inherited " ++ show ta2) + return () + checkConvert _ _ _ _ = return () + +mergeFunctions :: (Show c, MergeableM m, CompileErrorM m, TypeResolver r) => + r -> CategoryMap c -> ParamFilters -> [ValueRefine c] -> + [ValueDefine c] -> [ScopedFunction c] -> m [ScopedFunction c] +mergeFunctions r tm fm rs ds fs = do + inheritValue <- fmap concat $ collectAllOrErrorM $ map (getRefinesFuncs tm) rs + inheritType <- fmap concat $ collectAllOrErrorM $ map (getDefinesFuncs tm) ds + let inheritByName = Map.fromListWith (++) $ map (\f -> (sfName f,[f])) $ inheritValue ++ inheritType + let explicitByName = Map.fromListWith (++) $ map (\f -> (sfName f,[f])) fs + let allNames = Set.toList $ Set.union (Map.keysSet inheritByName) (Map.keysSet explicitByName) + collectAllOrErrorM $ map (mergeByName r fm inheritByName explicitByName) allNames +getRefinesFuncs tm ra@(ValueRefine c (TypeInstance n ts)) = flip reviseError (show ra) $ do + (_,t) <- getValueCategory tm (c,n) + let ps = map vpParam $ getCategoryParams t + let fs = getCategoryFunctions t + paired <- processPairs alwaysPair (Positional ps) ts + let assigned = Map.fromList paired + collectAllOrErrorM (map (uncheckedSubFunction assigned) fs) +getDefinesFuncs tm da@(ValueDefine c (DefinesInstance n ts)) = flip reviseError (show da) $ do + (_,t) <- getInstanceCategory tm (c,n) + let ps = map vpParam $ getCategoryParams t + let fs = getCategoryFunctions t + paired <- processPairs alwaysPair (Positional ps) ts + let assigned = Map.fromList paired + collectAllOrErrorM (map (uncheckedSubFunction assigned) fs) +mergeByName r fm im em n = + tryMerge r fm n (n `Map.lookup` im) (n `Map.lookup` em) +-- Inherited without an override. +tryMerge _ _ n (Just is) Nothing + | length is == 1 = return $ head is + | otherwise = compileError $ "Function " ++ show n ++ " is inherited " ++ + show (length is) ++ " times:\n---\n" ++ + intercalate "\n---\n" (map show is) +-- Not inherited. +tryMerge r fm n Nothing es = tryMerge r fm n (Just []) es +-- Explicit override, possibly inherited. +tryMerge r fm n (Just is) (Just es) + | length es /= 1 = compileError $ "Function " ++ show n ++ " is declared " ++ + show (length es) ++ " times:\n---\n" ++ + intercalate "\n---\n" (map show es) + | otherwise = do + let ff@(ScopedFunction c n t s as rs ps fa ms) = head es + mergeAllM $ map (checkMerge r fm ff) is + return $ ScopedFunction c n t s as rs ps fa (ms ++ is) + where + checkMerge r fm f1 f2 + | sfScope f1 /= sfScope f2 = + compileError $ "Cannot merge " ++ showScope (sfScope f2) ++ " with " ++ + showScope (sfScope f1) ++ " in function merge:\n---\n" ++ + show f2 ++ "\n ->\n" ++ show f1 + | otherwise = + flip reviseError ("In function merge:\n---\n" ++ show f2 ++ + "\n ->\n" ++ show f1 ++ "\n---\n") $ do + f1' <- parsedToFunctionType f1 + f2' <- parsedToFunctionType f2 + checkFunctionConvert r fm f2' f1' + +data FunctionName = + FunctionName { + fnName :: String + } | + BuiltinPresent | + BuiltinReduce | + BuiltinRequire | + BuiltinStrong | + BuiltinTypename + deriving (Eq,Ord) + +instance Show FunctionName where + show (FunctionName n) = n + show BuiltinPresent = "present" + show BuiltinReduce = "reduce" + show BuiltinRequire = "require" + show BuiltinStrong = "strong" + show BuiltinTypename = "typename" + +data ScopedFunction c = + ScopedFunction { + sfContext :: [c], + sfName :: FunctionName, + sfType :: CategoryName, + sfScope :: SymbolScope, + sfArgs :: Positional (PassedValue c), + sfReturns :: Positional (PassedValue c), + sfParams :: Positional (ValueParam c), + sfFilters :: [ParamFilter c], + sfMerges :: [ScopedFunction c] + } + +instance Show c => Show (ScopedFunction c) where + show f = showFunctionInContext (showScope (sfScope f) ++ " ") "" f + +showFunctionInContext :: Show c => String -> String -> ScopedFunction c -> String +showFunctionInContext s indent (ScopedFunction cs n t _ as rs ps fa ms) = + indent ++ s ++ "/*" ++ show t ++ "*/ " ++ show n ++ + showParams (pValues ps) ++ " " ++ formatContext cs ++ "\n" ++ + concat (map (\v -> indent ++ formatValue v ++ "\n") fa) ++ + indent ++ "(" ++ intercalate "," (map (show . pvType) $ pValues as) ++ ") -> " ++ + "(" ++ intercalate "," (map (show . pvType) $ pValues rs) ++ ")" ++ showMerges (flatten ms) + where + showParams [] = "" + showParams ps = "<" ++ intercalate "," (map (show . vpParam) ps) ++ ">" + formatContext cs = "/*" ++ formatFullContext cs ++ "*/" + formatValue v = " " ++ show (pfParam v) ++ " " ++ show (pfFilter v) ++ + " " ++ formatContext (pfContext v) + flatten [] = Set.empty + flatten ms = Set.unions $ (Set.fromList $ map sfType ms):(map (flatten . sfMerges) ms) + showMerges ms + | null (Set.toList ms) = " /*not merged*/" + | otherwise = " /*merged from: " ++ intercalate ", " (map show $ Set.toList ms) ++ "*/" + +data PassedValue c = + PassedValue { + pvContext :: [c], + pvType :: ValueType + } + +instance Show c => Show (PassedValue c) where + show (PassedValue c t) = show t ++ formatFullContextBrace c + +parsedToFunctionType :: (Show c, MergeableM m, CompileErrorM m) => + ScopedFunction c -> m FunctionType +parsedToFunctionType (ScopedFunction c n t _ as rs ps fa _) = do + let as' = Positional $ map pvType $ pValues as + let rs' = Positional $ map pvType $ pValues rs + let ps' = Positional $ map vpParam $ pValues ps + mergeAllM $ map checkFilter fa + let fm = Map.fromListWith (++) $ map (\f -> (pfParam f,[pfFilter f])) fa + let fa' = Positional $ map (getFilters fm) $ pValues ps' + return $ FunctionType as' rs' ps' fa' + where + pa = Set.fromList $ map vpParam $ pValues ps + checkFilter f = + when (not $ (pfParam f) `Set.member` pa) $ + compileError $ "Filtered param " ++ show (pfParam f) ++ + " is not defined for function " ++ show n ++ + formatFullContextBrace c + getFilters fm n = + case n `Map.lookup` fm of + (Just fs) -> fs + _ -> [] + +uncheckedSubFunction :: (Show c, MergeableM m, CompileErrorM m) => + Map.Map ParamName GeneralInstance -> ScopedFunction c -> m (ScopedFunction c) +uncheckedSubFunction pa ff@(ScopedFunction c n t s as rs ps fa ms) = + flip reviseError ("In function:\n---\n" ++ show ff ++ "\n---\n") $ do + let fixed = Map.fromList $ map (\n -> (n,SingleType $ JustParamName n)) $ map vpParam $ pValues ps + let pa' = Map.union pa fixed + as' <- fmap Positional $ collectAllOrErrorM $ map (subPassed pa') $ pValues as + rs' <- fmap Positional $ collectAllOrErrorM $ map (subPassed pa') $ pValues rs + fa' <- collectAllOrErrorM $ map (subFilter pa') fa + ms' <- collectAllOrErrorM $ map (uncheckedSubFunction pa) ms + return $ (ScopedFunction c n t s as' rs' ps fa' ms') + where + subPassed pa (PassedValue c t) = do + t' <- uncheckedSubValueType (getValueForParam pa) t + return $ PassedValue c t' + subFilter pa (ParamFilter c n f) = do + f' <- uncheckedSubFilter (getValueForParam pa) f + return $ ParamFilter c n f' diff --git a/src/Types/TypeInstance.hs b/src/Types/TypeInstance.hs new file mode 100644 --- /dev/null +++ b/src/Types/TypeInstance.hs @@ -0,0 +1,537 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} + +module Types.TypeInstance ( + AnyTypeResolver(..), + CategoryName(..), + DefinesInstance(..), + FilterDirection(..), + GeneralInstance, + InstanceFilters, + InstanceParams, + InstanceVariances, + ParamFilters, + ParamVariances, + ParamName(..), + StorageType(..), + TypeFilter(..), + TypeInstance(..), + TypeInstanceOrParam(..), + TypeResolver(..), + ValueType(..), + checkDefinesMatch, + checkGeneralMatch, + checkValueTypeMatch, + uncheckedSubFilter, + uncheckedSubFilters, + uncheckedSubInstance, + uncheckedSubValueType, + getValueForParam, + isBuiltinCategory, + isDefinesFilter, + isRequiresFilter, + isWeakValue, + requiredParam, + requiredSingleton, + validateAssignment, + validateDefinesInstance, + validateDefinesVariance, + validateGeneralInstance, + validateInstanceVariance, + validateTypeFilter, + validateTypeInstance, +) where + +import Control.Monad (when) +import Data.List (intercalate) +import qualified Data.Map as Map + +import Base.CompileError +import Base.Mergeable +import Types.GeneralType +import Types.Positional +import Types.Variance + + +type GeneralInstance = GeneralType TypeInstanceOrParam + +instance Show GeneralInstance where + show (SingleType t) = show t + show (TypeMerge MergeUnion []) = "all" + show (TypeMerge MergeUnion ts) = "[" ++ intercalate "|" (map show ts) ++ "]" + show (TypeMerge MergeIntersect []) = "any" + show (TypeMerge MergeIntersect ts) = "[" ++ intercalate "&" (map show ts) ++ "]" + +data StorageType = + WeakValue | + OptionalValue | + RequiredValue + deriving (Eq,Ord) + +data ValueType = + ValueType { + vtRequired :: StorageType, + vtType :: GeneralInstance + } + deriving (Eq,Ord) + +instance Show ValueType where + show (ValueType WeakValue t) = "weak " ++ show t + show (ValueType OptionalValue t) = "optional " ++ show t + show (ValueType RequiredValue t) = show t + +isWeakValue :: ValueType -> Bool +isWeakValue = (== WeakValue) . vtRequired + +requiredSingleton :: CategoryName -> ValueType +requiredSingleton n = ValueType RequiredValue $ SingleType $ JustTypeInstance $ TypeInstance n (Positional []) + +requiredParam :: ParamName -> ValueType +requiredParam n = ValueType RequiredValue $ SingleType $ JustParamName n + +data CategoryName = + CategoryName { + tnName :: String + } | + BuiltinBool | + BuiltinChar | + BuiltinInt | + BuiltinFloat | + BuiltinString | + BuiltinFormatted | + CategoryNone + +instance Show CategoryName where + show (CategoryName n) = n + show BuiltinBool = "Bool" + show BuiltinChar = "Char" + show BuiltinInt = "Int" + show BuiltinFloat = "Float" + show BuiltinString = "String" + show BuiltinFormatted = "Formatted" + show CategoryNone = "(none)" + +instance Eq CategoryName where + c1 == c2 = show c1 == show c2 + +instance Ord CategoryName where + c1 <= c2 = show c1 <= show c2 + +isBuiltinCategory :: CategoryName -> Bool +isBuiltinCategory _ = False + +newtype ParamName = + ParamName { + pnName :: String + } + deriving (Eq,Ord) + +instance Show ParamName where + show (ParamName n) = n + +data TypeInstance = + TypeInstance { + tiName :: CategoryName, + tiParams :: InstanceParams + } + deriving (Eq,Ord) + +instance Show TypeInstance where + show (TypeInstance n (Positional [])) = show n + show (TypeInstance n (Positional ts)) = + show n ++ "<" ++ intercalate "," (map show ts) ++ ">" + +data DefinesInstance = + DefinesInstance { + diName :: CategoryName, + diParams :: InstanceParams + } + deriving (Eq,Ord) + +instance Show DefinesInstance where + show (DefinesInstance n (Positional [])) = show n + show (DefinesInstance n (Positional ts)) = + show n ++ "<" ++ intercalate "," (map show ts) ++ ">" + +data TypeInstanceOrParam = + JustTypeInstance { + jtiType :: TypeInstance + } | + JustParamName { + jpnName :: ParamName + } + deriving (Eq,Ord) + +instance Show TypeInstanceOrParam where + show (JustTypeInstance t) = show t + show (JustParamName n) = show n + +data FilterDirection = + FilterRequires | + FilterAllows + deriving (Eq,Ord) + +data TypeFilter = + TypeFilter { + tfDirection :: FilterDirection, + tfType :: TypeInstanceOrParam + } | + DefinesFilter { + dfType :: DefinesInstance + } + deriving (Eq,Ord) + +instance Show TypeFilter where + show (TypeFilter FilterRequires t) = "requires " ++ show t + show (TypeFilter FilterAllows t) = "allows " ++ show t + show (DefinesFilter t) = "defines " ++ show t + +isTypeFilter :: TypeFilter -> Bool +isTypeFilter (TypeFilter _ _) = True +isTypeFilter _ = False + +isRequiresFilter :: TypeFilter -> Bool +isRequiresFilter (TypeFilter isRequiresFilter _) = True +isRequiresFilter _ = False + +isDefinesFilter :: TypeFilter -> Bool +isDefinesFilter (DefinesFilter _) = True +isDefinesFilter _ = False + +viewTypeFilter :: ParamName -> TypeFilter -> String +viewTypeFilter n f = show n ++ " " ++ show f + +type InstanceParams = Positional GeneralInstance +type InstanceVariances = Positional Variance +type InstanceFilters = Positional [TypeFilter] + +type ParamFilters = Map.Map ParamName [TypeFilter] +type ParamVariances = Map.Map ParamName Variance + +class TypeResolver r where + -- Performs parameter substitution for refines. + trRefines :: (MergeableM m, CompileErrorM m) => + r -> TypeInstance -> CategoryName -> m InstanceParams + -- Performs parameter substitution for defines. + trDefines :: (MergeableM m, CompileErrorM m) => + r -> TypeInstance -> CategoryName -> m InstanceParams + -- Get the parameter variances for the category. + trVariance :: (MergeableM m, CompileErrorM m) => + r -> CategoryName -> m InstanceVariances + -- Gets filters for the assigned parameters. + trTypeFilters :: (MergeableM m, CompileErrorM m) => + r -> TypeInstance -> m InstanceFilters + -- Gets filters for the assigned parameters. + trDefinesFilters :: (MergeableM m, CompileErrorM m) => + r -> DefinesInstance -> m InstanceFilters + -- Returns True if the type is concrete. + trConcrete :: (MergeableM m, CompileErrorM m) => + r -> CategoryName -> m Bool + +data AnyTypeResolver = forall r. TypeResolver r => AnyTypeResolver r + +instance TypeResolver AnyTypeResolver where + trRefines (AnyTypeResolver r) = trRefines r + trDefines (AnyTypeResolver r) = trDefines r + trVariance (AnyTypeResolver r) = trVariance r + trTypeFilters (AnyTypeResolver r) = trTypeFilters r + trDefinesFilters (AnyTypeResolver r) = trDefinesFilters r + trConcrete (AnyTypeResolver r) = trConcrete r + +filterLookup :: (CompileErrorM m) => + ParamFilters -> ParamName -> m [TypeFilter] +filterLookup ps n = resolve $ n `Map.lookup` ps where + resolve (Just x) = return x + resolve _ = compileError $ "Param " ++ show n ++ " not found" + +getValueForParam :: (CompileErrorM m) => + Map.Map ParamName GeneralInstance -> ParamName -> m GeneralInstance +getValueForParam pa n = + case n `Map.lookup` pa of + (Just x) -> return x + _ -> compileError $ "Param " ++ show n ++ " does not exist" + +checkValueTypeMatch :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> ValueType -> ValueType -> m () +checkValueTypeMatch r f ts1@(ValueType r1 t1) ts2@(ValueType r2 t2) + | r1 < r2 = + compileError $ "Cannot convert " ++ show ts1 ++ " to " ++ show ts2 + | otherwise = checkGeneralMatch r f Covariant t1 t2 + +checkGeneralMatch :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> Variance -> + GeneralInstance -> GeneralInstance -> m () +checkGeneralMatch r f Invariant ts1 ts2 = do + -- This ensures that any and all behave as expected in Invariant positions. + checkGeneralType (checkSingleMatch r f Covariant) ts1 ts2 + checkGeneralType (checkSingleMatch r f Covariant) ts2 ts1 +checkGeneralMatch r f Contravariant ts1 ts2 = + checkGeneralType (checkSingleMatch r f Covariant) ts2 ts1 +checkGeneralMatch r f Covariant ts1 ts2 = + checkGeneralType (checkSingleMatch r f Covariant) ts1 ts2 + +checkSingleMatch :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> Variance -> + TypeInstanceOrParam -> TypeInstanceOrParam -> m () +checkSingleMatch r f v (JustTypeInstance t1) (JustTypeInstance t2) = + checkInstanceToInstance r f v t1 t2 +checkSingleMatch r f v (JustParamName p1) (JustTypeInstance t2) = + checkParamToInstance r f v p1 t2 +checkSingleMatch r f v (JustTypeInstance t1) (JustParamName p2) = + checkInstanceToParam r f v t1 p2 +checkSingleMatch r f v (JustParamName p1) (JustParamName p2) = + checkParamToParam r f v p1 p2 + +checkInstanceToInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> Variance -> TypeInstance -> TypeInstance -> m () +checkInstanceToInstance r f Invariant t1 t2 + | t1 == t2 = mergeDefaultM + | otherwise = + -- Implicit equality, inferred by t1 <-> t2. + mergeAllM [checkInstanceToInstance r f Covariant t1 t2, + checkInstanceToInstance r f Contravariant t1 t2] +checkInstanceToInstance r f Contravariant t1 t2 = + checkInstanceToInstance r f Covariant t2 t1 +checkInstanceToInstance r f Covariant t1@(TypeInstance n1 ps1) t2@(TypeInstance n2 ps2) + | n1 == n2 = do + paired <- processPairs alwaysPair ps1 ps2 + let zipped = Positional paired + variance <- trVariance r n1 + -- NOTE: Covariant is identity, so v2 has technically been composed with it. + processPairs (\v2 (p1,p2) -> checkGeneralMatch r f v2 p1 p2) variance zipped >> mergeDefaultM + | otherwise = do + ps1' <- trRefines r t1 n2 + checkInstanceToInstance r f Covariant (TypeInstance n2 ps1') t2 + +checkParamToInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> Variance -> ParamName -> TypeInstance -> m () +checkParamToInstance r f Invariant n1 t2 = + -- Implicit equality, inferred by n1 <-> t2. + mergeAllM [checkParamToInstance r f Covariant n1 t2, + checkParamToInstance r f Contravariant n1 t2] +checkParamToInstance r f Contravariant p1 t2 = + checkInstanceToParam r f Covariant t2 p1 +checkParamToInstance r f Covariant n1 t2@(TypeInstance n2 ps2) = do + cs1 <- fmap (filter isTypeFilter) $ f `filterLookup` n1 + mergeAnyM (map checkConstraintToInstance cs1) `reviseError` + ("No filters imply " ++ show n1 ++ " -> " ++ show t2) + where + checkConstraintToInstance (TypeFilter FilterRequires t) = + -- x -> F implies x -> T only if F -> T + checkSingleMatch r f Covariant t (JustTypeInstance t2) + checkConstraintToInstance f = + -- F -> x cannot imply x -> T + -- DefinesInstance cannot be converted to TypeInstance + compileError $ "Constraint " ++ viewTypeFilter n1 f ++ + " does not imply " ++ show n1 ++ " -> " ++ show t2 + +checkInstanceToParam :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> Variance -> TypeInstance -> ParamName -> m () +checkInstanceToParam r f Invariant t1 n2 = + -- Implicit equality, inferred by t1 <-> n2. + mergeAllM [checkInstanceToParam r f Covariant t1 n2, + checkInstanceToParam r f Contravariant t1 n2] +checkInstanceToParam r f Contravariant t1 p2 = + checkParamToInstance r f Covariant p2 t1 +checkInstanceToParam r f Covariant t1@(TypeInstance n1 ps1) n2 = do + cs2 <- fmap (filter isTypeFilter) $ f `filterLookup` n2 + mergeAnyM (map checkInstanceToConstraint cs2) `reviseError` + ("No filters imply " ++ show t1 ++ " -> " ++ show n2) + where + checkInstanceToConstraint (TypeFilter FilterAllows t) = + -- F -> x implies T -> x only if T -> F + checkSingleMatch r f Covariant (JustTypeInstance t1) t + checkInstanceToConstraint f = + -- x -> F cannot imply T -> x + compileError $ "Constraint " ++ viewTypeFilter n2 f ++ + " does not imply " ++ show t1 ++ " -> " ++ show n2 + +checkParamToParam :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> Variance -> ParamName -> ParamName -> m () +checkParamToParam r f Invariant n1 n2 + | n1 == n2 = mergeDefaultM + | otherwise = + -- Implicit equality, inferred by n1 <-> n2. + mergeAllM [checkParamToParam r f Covariant n1 n2, + checkParamToParam r f Contravariant n1 n2] +checkParamToParam r f Contravariant n1 n2 = + checkParamToParam r f Covariant n2 n1 +checkParamToParam r f Covariant n1 n2 + | n1 == n2 = mergeDefaultM + | otherwise = do + cs1 <- fmap (filter isTypeFilter) $ f `filterLookup` n1 + cs2 <- fmap (filter isTypeFilter) $ f `filterLookup` n2 + let typeFilters = [(c1,c2) | c1 <- cs1, c2 <- cs2] ++ + [(self1,c2) | c2 <- cs2] ++ + [(c1,self2) | c1 <- cs1] + mergeAnyM (map (\(c1,c2) -> checkConstraintToConstraint c1 c2) typeFilters) `reviseError` + ("No filters imply " ++ show n1 ++ " -> " ++ show n2) + where + self1 = TypeFilter FilterRequires (JustParamName n1) + self2 = TypeFilter FilterAllows (JustParamName n2) + checkConstraintToConstraint (TypeFilter FilterRequires t1) (TypeFilter FilterAllows t2) + | t1 == (JustParamName n1) && t2 == (JustParamName n2) = + compileError $ "Infinite recursion in " ++ show n1 ++ " -> " ++ show n2 + -- x -> F1, F2 -> y implies x -> y only if F1 -> F2 + | otherwise = checkSingleMatch r f Covariant t1 t2 + checkConstraintToConstraint f1 f2 = + -- x -> F1, y -> F2 cannot imply x -> y + -- F1 -> x, F1 -> y cannot imply x -> y + -- F1 -> x, y -> F2 cannot imply x -> y + compileError $ "Constraints " ++ viewTypeFilter n1 f1 ++ " and " ++ + viewTypeFilter n2 f2 ++ " do not imply " ++ + show n1 ++ " -> " ++ show n2 + +validateGeneralInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> GeneralInstance -> m () +validateGeneralInstance r f ta@(TypeMerge _ ts) + | length ts == 1 = compileError $ "Unions and intersections must have at least 2 types to avoid ambiguity" +validateGeneralInstance r f ta@(TypeMerge MergeIntersect ts) = + mergeAllM (map (validateGeneralInstance r f) ts) +validateGeneralInstance r f ta@(TypeMerge _ ts) = + mergeAllM (map (validateGeneralInstance r f) ts) +validateGeneralInstance r f (SingleType (JustTypeInstance t)) = + validateTypeInstance r f t +validateGeneralInstance _ f (SingleType (JustParamName n)) = + when (not $ n `Map.member` f) $ + compileError $ "Param " ++ show n ++ " does not exist" + +validateTypeInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> TypeInstance -> m () +validateTypeInstance r f t@(TypeInstance n ps) = do + fa <- trTypeFilters r t + processPairs (validateAssignment r f) ps fa + mergeAllM (map (validateGeneralInstance r f) (pValues ps)) `reviseError` + ("Recursive error in " ++ show t) + +validateDefinesInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> DefinesInstance -> m () +validateDefinesInstance r f t@(DefinesInstance n ps) = do + fa <- trDefinesFilters r t + processPairs (validateAssignment r f) ps fa + mergeAllM (map (validateGeneralInstance r f) (pValues ps)) `reviseError` + ("Recursive error in " ++ show t) + +validateTypeFilter :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> TypeFilter -> m () +validateTypeFilter r f (TypeFilter _ t) = + validateGeneralInstance r f (SingleType t) +validateTypeFilter r f (DefinesFilter t) = + validateDefinesInstance r f t + +validateAssignment :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> GeneralInstance -> [TypeFilter] -> m () +validateAssignment r f t fs = mergeAllM (map (checkFilter t) fs) where + checkFilter t1 (TypeFilter FilterRequires t2) = do + checkGeneralMatch r f Covariant t1 (SingleType t2) + checkFilter t1 (TypeFilter FilterAllows t2) = do + checkGeneralMatch r f Contravariant t1 (SingleType t2) + checkFilter t1@(TypeMerge _ _) (DefinesFilter t) = + compileError $ "Merged type " ++ show t1 ++ " cannot satisfy defines constraint " ++ show t + checkFilter t1@(SingleType t) (DefinesFilter f) = checkDefinesFilter f t + requireExactlyOne t [_] = mergeDefaultM + requireExactlyOne t [] = + compileError $ "No types in intersection define " ++ show t + requireExactlyOne t ts = + (compileError $ "Multiple types in intersection define " ++ show t) `mergeNestedM` + (mergeAllM $ map (compileError . show) ts) + checkDefinesFilter f2@(DefinesInstance n2 _) (JustTypeInstance t1) = do + ps1' <- trDefines r t1 n2 + checkDefinesMatch r f f2 (DefinesInstance n2 ps1') + checkDefinesFilter f2 (JustParamName n1) = do + fs1 <- fmap (map dfType . filter isDefinesFilter) $ f `filterLookup` n1 + mergeAnyM (map (checkDefinesMatch r f f2) fs1) `reviseError` + ("No filters imply " ++ show n1 ++ " defines " ++ show f2) + +checkDefinesMatch :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> DefinesInstance -> DefinesInstance -> m () +checkDefinesMatch r f f2@(DefinesInstance n2 ps2) f1@(DefinesInstance n1 ps1) + | n1 == n2 = do + paired <- processPairs alwaysPair ps1 ps2 + variance <- trVariance r n2 + processPairs (\v2 (p1,p2) -> checkGeneralMatch r f v2 p1 p2) variance (Positional paired) + mergeDefaultM + | otherwise = compileError $ "Constraint " ++ show f1 ++ " does not imply " ++ show f2 + +validateInstanceVariance :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamVariances -> Variance -> GeneralInstance -> m () +validateInstanceVariance r vm v (SingleType (JustTypeInstance (TypeInstance n ps))) = do + vs <- trVariance r n + paired <- processPairs alwaysPair vs ps + mergeAllM (map (\(v2,p) -> validateInstanceVariance r vm (v `composeVariance` v2) p) paired) +validateInstanceVariance r vm v (TypeMerge MergeUnion ts) = + mergeAllM (map (validateInstanceVariance r vm v) ts) +validateInstanceVariance r vm v (TypeMerge MergeIntersect ts) = + mergeAllM (map (validateInstanceVariance r vm v) ts) +validateInstanceVariance r vm v (SingleType (JustParamName n)) = + case n `Map.lookup` vm of + Nothing -> compileError $ "Param " ++ show n ++ " is undefined" + (Just v0) -> when (not $ v0 `paramAllowsVariance` v) $ + compileError $ "Param " ++ show n ++ " cannot be " ++ show v + +validateDefinesVariance :: (MergeableM m, CompileErrorM m, TypeResolver r) => + r -> ParamVariances -> Variance -> DefinesInstance -> m () +validateDefinesVariance r vm v (DefinesInstance n ps) = do + vs <- trVariance r n + paired <- processPairs alwaysPair vs ps + mergeAllM (map (\(v2,p) -> validateInstanceVariance r vm (v `composeVariance` v2) p) paired) + +uncheckedSubValueType :: (MergeableM m, CompileErrorM m) => + (ParamName -> m GeneralInstance) -> ValueType -> m ValueType +uncheckedSubValueType replace (ValueType s t) = do + t' <- uncheckedSubInstance replace t + return $ ValueType s t' + +uncheckedSubInstance :: (MergeableM m, CompileErrorM m) => + (ParamName -> m GeneralInstance) -> GeneralInstance -> m GeneralInstance +uncheckedSubInstance replace = subAll where + subAll (TypeMerge MergeUnion ts) = do + gs <- collectAllOrErrorM $ map subAll ts + return (TypeMerge MergeUnion gs) + subAll (TypeMerge MergeIntersect ts) = do + gs <- collectAllOrErrorM $ map subAll ts + return (TypeMerge MergeIntersect gs) + subAll (SingleType t) = subInstance t + subInstance (JustTypeInstance (TypeInstance n (Positional ts))) = do + gs <- collectAllOrErrorM $ map subAll ts + let t2 = SingleType $ JustTypeInstance $ TypeInstance n (Positional gs) + return (t2) + subInstance (JustParamName n) = replace n + +uncheckedSubFilter :: (MergeableM m, CompileErrorM m) => + (ParamName -> m GeneralInstance) -> TypeFilter -> m TypeFilter +uncheckedSubFilter replace (TypeFilter d t) = do + t' <- uncheckedSubInstance replace (SingleType t) + return (TypeFilter d (stType t')) +uncheckedSubFilter replace (DefinesFilter (DefinesInstance n ts)) = do + ts' <- collectAllOrErrorM $ map (uncheckedSubInstance replace) (pValues ts) + return (DefinesFilter (DefinesInstance n (Positional ts'))) + +uncheckedSubFilters :: (MergeableM m, CompileErrorM m) => + (ParamName -> m GeneralInstance) -> ParamFilters -> m ParamFilters +uncheckedSubFilters replace fa = do + fa' <- collectAllOrErrorM $ map subParam $ Map.toList fa + return $ Map.fromList fa' + where + subParam (n,fs) = do + fs' <- collectAllOrErrorM $ map (uncheckedSubFilter replace) fs + return (n,fs') diff --git a/src/Types/Variance.hs b/src/Types/Variance.hs new file mode 100644 --- /dev/null +++ b/src/Types/Variance.hs @@ -0,0 +1,52 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Types.Variance ( + Variance(..), + composeVariance, + paramAllowsVariance, +) where + + +data Variance = + Contravariant | + Invariant | + Covariant + deriving (Eq,Ord) + +instance Show Variance where + show Contravariant = "contravariant" + show Invariant = "invariant" + show Covariant = "covariant" + +composeVariance :: Variance -> Variance -> Variance +composeVariance Covariant Covariant = Covariant +composeVariance Contravariant Contravariant = Covariant +composeVariance Contravariant Covariant = Contravariant +composeVariance Covariant Contravariant = Contravariant +composeVariance _ _ = Invariant + +paramAllowsVariance :: Variance -> Variance -> Bool +Covariant `paramAllowsVariance` Covariant = True +Contravariant `paramAllowsVariance` Contravariant = True +Invariant `paramAllowsVariance` Covariant = True +Invariant `paramAllowsVariance` Invariant = True +Invariant `paramAllowsVariance` Contravariant = True +_ `paramAllowsVariance` _ = False diff --git a/tests/.zeolite-module b/tests/.zeolite-module new file mode 100644 --- /dev/null +++ b/tests/.zeolite-module @@ -0,0 +1,1 @@ +RecompileMetadata {rmRoot = "..", rmPath = "tests", rmPublicDeps = ["visibility","visibility2"], rmPrivateDeps = [], rmExtraFiles = [], rmExtraPaths = [], rmExtraRequires = [], rmMode = CompileIncremental, rmOutputName = ""} diff --git a/tests/assignments.0rt b/tests/assignments.0rt new file mode 100644 --- /dev/null +++ b/tests/assignments.0rt @@ -0,0 +1,54 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "overwrite arg" { + error + require "arg" +} + +define Test { + @type call (Int) -> () + call (arg) { + arg <- 2 + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "self in @category function" { + error + require "self" +} + +define Test { + @category call () -> () + call () { + Test value <- self + } + + run () {} +} + +concrete Test { + @type run () -> () +} diff --git a/tests/builtin-types.0rt b/tests/builtin-types.0rt new file mode 100644 --- /dev/null +++ b/tests/builtin-types.0rt @@ -0,0 +1,1032 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "not true" { + success Test$run() +} + +define Test { + run () { + if (!true) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce Bool" { + success Test$run() +} + +define Test { + run () { + if (!present(reduce(true))) { + fail("Failed") + } + if (!present(reduce(true))) { + fail("Failed") + } + if (present(reduce(true))) { + fail("Failed") + } + if (!present(reduce(true))) { + fail("Failed") + } + if (!present(reduce(true))) { + fail("Failed") + } + if (!present(reduce(true))) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce Char" { + success Test$run() +} + +define Test { + run () { + if (!present(reduce('a'))) { + fail("Failed") + } + if (!present(reduce('a'))) { + fail("Failed") + } + if (!present(reduce('a'))) { + fail("Failed") + } + if (!present(reduce('a'))) { + fail("Failed") + } + if (!present(reduce('a'))) { + fail("Failed") + } + if (!present(reduce('a'))) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce Int" { + success Test$run() +} + +define Test { + run () { + if (!present(reduce(1))) { + fail("Failed") + } + if (!present(reduce(1))) { + fail("Failed") + } + if (!present(reduce(1))) { + fail("Failed") + } + if (!present(reduce(1))) { + fail("Failed") + } + if (!present(reduce(1))) { + fail("Failed") + } + if (!present(reduce(1))) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce Float" { + success Test$run() +} + +define Test { + run () { + if (!present(reduce(1.0))) { + fail("Failed") + } + if (!present(reduce(1.0))) { + fail("Failed") + } + if (present(reduce(1.0))) { + fail("Failed") + } + if (!present(reduce(1.0))) { + fail("Failed") + } + if (!present(reduce(1.0))) { + fail("Failed") + } + if (!present(reduce(1.0))) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce String" { + success Test$run() +} + +define Test { + run () { + if (!present(reduce("a"))) { + fail("Failed") + } + if (!present(reduce("a"))) { + fail("Failed") + } + if (present(reduce("a"))) { + fail("Failed") + } + if (present(reduce("a"))) { + fail("Failed") + } + if (present(reduce("a"))) { + fail("Failed") + } + if (!present(reduce("a"))) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce ReadPosition success" { + success Test$run() +} + +define Test { + run () { + if (!present(reduce,ReadPosition>("x"))) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce ReadPosition fail" { + success Test$run() +} + +define Test { + run () { + if (present(reduce,ReadPosition>("x"))) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "String LessThan" { + success Test$run() +} + +define Test { + run () { + if (!("x" `String$lessThan` "y")) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Bool Equals" { + success Test$run() +} + +define Test { + run () { + if (!(true `Bool$equals` true)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "String Equals" { + success Test$run() +} + +define Test { + run () { + if (!("x" `String$equals` "x")) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Char LessThan" { + success Test$run() +} + +define Test { + run () { + if (!('x' `Char$lessThan` 'y')) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Char Equals" { + success Test$run() +} + +define Test { + run () { + if (!('x' `Char$equals` 'x')) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Int LessThan" { + success Test$run() +} + +define Test { + run () { + if (!(1 `Int$lessThan` 2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Int Equals" { + success Test$run() +} + +define Test { + run () { + if (!(1 `Int$equals` 1)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Float LessThan" { + success Test$run() +} + +define Test { + run () { + if (!(1.0 `Float$lessThan` 2.0)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Float Equals" { + success Test$run() +} + +define Test { + run () { + if (!(1.0 `Float$equals` 1.0)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Bool is shared" { + success Test$run() +} + +define Test { + run () { + Bool value1 <- true + // Shared because true and false are boxed constants. + weak Bool value2 <- value1 + if (!present(strong(value2))) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "String is shared" { + success Test$run() +} + +define Test { + run () { + String value1 <- "x" + weak String value2 <- value1 + if (!present(strong(value2))) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Char is not shared" { + success Test$run() +} + +define Test { + run () { + Char value1 <- 'x' + weak Char value2 <- value1 + if (present(strong(value2))) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Int is not shared" { + success Test$run() +} + +define Test { + run () { + Int value1 <- 1 + weak Int value2 <- value1 + if (present(strong(value2))) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Float is not shared" { + success Test$run() +} + +define Test { + run () { + Float value1 <- 1.1 + weak Float value2 <- value1 + if (present(strong(value2))) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "String Formatted" { + success Test$run() +} + +define Test { + run () { + String s <- ("x").formatted() + if (s != "x") { + fail(s) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Char Formatted" { + success Test$run() +} + +define Test { + run () { + String s <- ('x').formatted() + if (s != "x") { + fail(s) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Char octal Formatted" { + success Test$run() +} + +define Test { + run () { + String s <- ('\170').formatted() + if (s != "x") { + fail(s) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Char hex Formatted" { + success Test$run() +} + +define Test { + run () { + String s <- ('\x78').formatted() + if (s != "x") { + fail(s) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Int Formatted" { + success Test$run() +} + +define Test { + run () { + String s <- (1).formatted() + if (s != "1") { + fail(s) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Int hex Formatted" { + success Test$run() +} + +define Test { + run () { + String s <- (\x0010).formatted() + if (s != "16") { + fail(s) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Float Formatted" { + success Test$run() +} + +define Test { + run () { + String s <- (1.1).formatted() + if (s != "1.1") { // precision might vary + fail(s) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Bool Formatted" { + success Test$run() +} + +define Test { + run () { + String s <- (false).formatted() + if (s != "false") { + fail(s) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "String access" { + success Test$run() +} + +define Test { + run () { + String s <- "abcde" + Char c <- s.readPosition(3) + if (c != 'd') { + fail(c) + } + Int size <- s.readSize() + if (size != 5) { + fail(size) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "String access negative" { + crash Test$run() + require "-10" + require "bounds" +} + +define Test { + run () { + ~ ("abc").readPosition(-10) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "String access past end" { + crash Test$run() + require "100" + require "bounds" +} + +define Test { + run () { + ~ ("abc").readPosition(100) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "String subsequence" { + success Test$run() +} + +define Test { + run () { + String s <- "abcde" + String s2 <- s.subSequence(1,3) + if (s2 != "bcd") { + fail(s2) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "String empty subsequence at end" { + success Test$run() +} + +define Test { + run () { + String s <- "" + String s2 <- s.subSequence(0,0) + if (s2 != "") { + fail(s2) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "String subsequence past end" { + crash Test$run() + require "100" + require "size" +} + +define Test { + run () { + ~ ("abc").subSequence(1,100) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Int max is accurate" { + success Test$run() +} + +define Test { + run () { + Int x <- 9223372036854775807 - 1 + if (x != 9223372036854775806) { + fail(x) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Int min is accurate" { + success Test$run() +} + +define Test { + run () { + Int x <- -9223372036854775806 + 1 + if (x != -9223372036854775805) { + fail(x) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Int unsigned works properly" { + success Test$run() +} + +define Test { + run () { + if (\xffffffffffffffff != -1) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Int literal too large" { + error + require "9223372036854775808" + require "max" +} + +define Test { + run () { + ~ 9223372036854775808 + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Int unsigned literal too large" { + error + require "18446744073709551616" + require "max" +} + +define Test { + run () { + ~ \x10000000000000000 + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Int literal too small" { + error + require "-9223372036854775807" + require "min" +} + +define Test { + run () { + ~ -9223372036854775807 + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Float exponent does not cross whitespace" { + success Test$run() +} + +concrete E10 { + @type create () -> (E10) +} + +define E10 { + create () { + return E10{ } + } +} + +define Test { + run () { + Float x <- 1.2345 + E10 y <- E10$create() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "String allows null" { + success Test$run() +} + +define Test { + run () { + if ("abc\x00def" == "abc") { + fail("Failed") + } + if (("abc\x00def").readPosition(4) != 'd') { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Bool conversions" { + success Test$run() +} + +define Test { + run () { + Bool b1 <- (false).asBool() + if (b1 != false) { + fail(b1) + } + Bool b2 <- (true).asBool() + if (b2 != true) { + fail(b2) + } + Int i <- (true).asInt() + if (i != 1) { + fail(i) + } + Float f <- (true).asFloat() + if (f != 1.0) { + fail(f) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Char conversions" { + success Test$run() +} + +define Test { + run () { + Bool b1 <- ('\x00').asBool() + if (b1 != false) { + fail(b1) + } + Bool b2 <- ('\x10').asBool() + if (b2 != true) { + fail(b2) + } + Char c <- ('a').asChar() + if (c != 'a') { + fail(c) + } + Int i <- ('\x10').asInt() + if (i != 16) { + fail(i) + } + Float f <- ('\x10').asFloat() + if (f != 16.0) { + fail(f) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Int conversions" { + success Test$run() +} + +define Test { + run () { + Bool b1 <- (0).asBool() + if (b1 != false) { + fail(b1) + } + Bool b2 <- (16).asBool() + if (b2 != true) { + fail(b2) + } + Char c <- (97).asChar() + if (c != 'a') { + fail(c) + } + Int i <- (16).asInt() + if (i != 16) { + fail(i) + } + Float f <- (16).asFloat() + if (f != 16.0) { + fail(f) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Float conversions" { + success Test$run() +} + +define Test { + run () { + Bool b1 <- (0.0).asBool() + if (b1 != false) { + fail(b1) + } + Bool b2 <- (16.0).asBool() + if (b2 != true) { + fail(b2) + } + Int i <- (16.0).asInt() + if (i != 16) { + fail(i) + } + Float f <- (16.0).asFloat() + if (f != 16.0) { + fail(f) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "String conversions" { + success Test$run() +} + +define Test { + run () { + Bool b1 <- ("").asBool() + if (b1 != false) { + fail(b1) + } + Bool b2 <- ("\x00").asBool() + if (b2 != true) { + fail(b2) + } + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/conditionals.0rt b/tests/conditionals.0rt new file mode 100644 --- /dev/null +++ b/tests/conditionals.0rt @@ -0,0 +1,430 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "assign if/elif/else" { + success Test$run() +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value) + process () (value) { + if (false) { + value <- empty + } elif (false) { + value <- empty + } else { + value <- empty + } + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "return if/elif/else" { + success Test$run() +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value) + process () { + if (false) { + return empty + } elif (false) { + return empty + } else { + return empty + } + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "assign if/elif condition" { + error + require "value.+before return" +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value) + process () (value) { + if (present((value <- empty))) { + } elif (present((value <- empty))) { + } else { + value <- empty + } + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "different in if and else" { + error + require "value1.+before return" + require "value2.+before return" +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value,optional Value) + process () (value1,value2) { + if (false) { + value1 <- empty + } else { + value2 <- empty + } + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "missing in if" { + error + require "value.+before return" +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value) + process () (value) { + if (false) { + } elif (false) { + value <- empty + } else { + value <- empty + } + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "missing in elif" { + error + require "value.+before return" +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value) + process () (value) { + if (false) { + value <- empty + } elif (false) { + } else { + value <- empty + } + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "missing in else" { + error + require "value.+before return" +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value) + process () (value) { + if (false) { + value <- empty + } elif (false) { + value <- empty + } else { + } + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "missing in implicit else" { + error + require "value.+before return" +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value) + process () (value) { + if (false) { + value <- empty + } elif (false) { + value <- empty + } + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "crash in if" { + crash Test$run() + require "empty" +} + +define Test { + run () { + optional Bool test <- empty + if (require(test)) { + // empty + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "crash in elif" { + crash Test$run() + require "empty" +} + +define Test { + run () { + optional Bool test <- empty + if (false) { + } elif (require(test)) { + // empty + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "multi assign if/elif/else" { + success Test$run() +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value,optional Value) + process () (value1,value2) { + if (false) { + value1 <- empty + value2 <- empty + } elif (false) { + value1 <- empty + value2 <- empty + } else { + value1 <- empty + value2 <- empty + } + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "multi missing in if" { + error + require "value2" +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value,optional Value) + process () (value1,value2) { + if (false) { + value1 <- empty + } elif (false) { + value1 <- empty + value2 <- empty + } else { + value1 <- empty + value2 <- empty + } + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "multi missing in elif" { + error + require "value2" +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value,optional Value) + process () (value1,value2) { + if (false) { + value1 <- empty + value2 <- empty + } elif (false) { + value1 <- empty + } else { + value1 <- empty + value2 <- empty + } + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "multi missing in else" { + error + require "value2" +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value,optional Value) + process () (value1,value2) { + if (false) { + value1 <- empty + value2 <- empty + } elif (false) { + value1 <- empty + value2 <- empty + } else { + value1 <- empty + } + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "cleanup before return in if" { + success Test$run() +} + +concrete Value { + @type create () -> (Value) + @value call () -> (Int) + @value get () -> (Int) +} + +define Value { + @value Int value + + create () { + return Value{ 0 } + } + + call () { + value <- 1 + scoped { + value <- 2 + } cleanup { + value <- 3 + } in if (true) { + return value + } + return 4 + } + + get () { + return value + } +} + +define Test { + run () { + Value value <- Value$create() + Int value1 <- value.call() + if (value1 != 2) { + fail(value1) + } + Int value2 <- value.get() + if (value2 != 3) { + fail(value2) + } + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/failure.0rt b/tests/failure.0rt new file mode 100644 --- /dev/null +++ b/tests/failure.0rt @@ -0,0 +1,81 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "fail builtin" { + crash Test$run() + require stderr "Failed" +} + +define Test { + @category failedReturn () -> (Int) + failedReturn () { + fail("Failed") + } + + run () { + Int value <- failedReturn() + } +} + +concrete Test { + @type run () -> () +} + + + +testcase "wrong type for fail" { + error + require "fail" + require "Formatted" +} + +concrete Value { + @type create () -> (Value) +} + +define Value { + create () { + return Value{} + } +} + +define Test { + run () { + fail(Value$create()) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "require empty" { + crash Test$run() + require stderr "require.+empty" +} + +define Test { + run () { + ~ require(empty) + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/filters.0rt b/tests/filters.0rt new file mode 100644 --- /dev/null +++ b/tests/filters.0rt @@ -0,0 +1,41 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "external filter not applied in @category" { + success Test$run() +} + +concrete Value<#x> { + #x defines LessThan<#x> + + @category something<#x> () -> () +} + +define Value { + something () {} +} + +define Test { + run () { + ~ Value$$something() + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/function-calls.0rt b/tests/function-calls.0rt new file mode 100644 --- /dev/null +++ b/tests/function-calls.0rt @@ -0,0 +1,480 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "converted call" { + success Test$run() +} + +@value interface Base { + call () -> () +} + +concrete Value { + refines Base + + @type create () -> (Value) +} + +define Value { + call () {} + + create () { + return Value{} + } +} + +define Test { + run () { + Value value <- Value$create() + ~ value.Base$call() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "converted call bad type" { + error + require "Base" +} + +@value interface Base { + call () -> () +} + +concrete Value { + @value call () -> () + @type create () -> (Value) +} + +define Value { + call () {} + + create () { + return Value{} + } +} + +define Test { + run () { + Value value <- Value$create() + ~ value.Base$call() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "call from union" { + error + require "\[Base\|Value\]" +} + +@value interface Base { + call () -> () +} + +concrete Value { + refines Base + + @type create () -> (Value) +} + +define Value { + call () {} + + create () { + return Value{} + } +} + +define Test { + run () { + [Base|Value] value <- Value$create() + ~ value.call() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "call from union with conversion" { + success Test$run() +} + +@value interface Base { + call () -> () +} + +concrete Value { + refines Base + + @type create () -> (Value) +} + +define Value { + call () {} + + create () { + return Value{} + } +} + +define Test { + run () { + [Base|Value] value <- Value$create() + ~ value.Base$call() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "call from intersect" { + success Test$run() +} + +@value interface Base1 { + call () -> () +} + +@value interface Base2 {} + +concrete Value { + refines Base1 + refines Base2 + + @type create () -> (Value) +} + +define Value { + call () {} + + create () { + return Value{} + } +} + +define Test { + run () { + [Base1&Base2] value <- Value$create() + ~ value.call() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "call from intersect with conversion" { + success Test$run() +} + +@value interface Base1 { + call () -> () +} + +@value interface Base2 {} + +concrete Value { + refines Base1 + refines Base2 + + @type create () -> (Value) +} + +define Value { + call () {} + + create () { + return Value{} + } +} + +define Test { + run () { + [Base1&Base2] value <- Value$create() + ~ value.Base1$call() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "call from intersect with conversion" { + success Test$run() +} + +@value interface Base1 { + call () -> () +} + +@value interface Base2 {} + +concrete Value { + refines Base1 + refines Base2 + + @type create () -> (Value) +} + +define Value { + call () {} + + create () { + return Value{} + } +} + +define Test { + run () { + [Base1&Base2] value <- Value$create() + ~ value.Base1$call() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "call from param type" { + success Test$run() +} + +@type interface Base { + call () -> () +} + +concrete Value { + defines Base +} + +define Value { + call () {} +} + +define Test { + @type check<#x> + #x defines Base + () -> () + check () { + ~ #x$call() + } + + run () { + ~ check() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "call from bad param type" { + error + require "call.+param #x" +} + +@type interface Base { + call () -> () +} + +define Test { + @type check<#x> + () -> () + check () { + ~ #x$call() + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "call from param value" { + success Test$run() +} + +@value interface Base { + call () -> () +} + +concrete Value { + refines Base + + @type create () -> (Value) +} + +define Value { + call () {} + + create () { + return Value{} + } +} + +define Test { + @type check<#x> + #x requires Base + (#x) -> () + check (value) { + ~ value.call() + } + + run () { + Value value <- Value$create() + ~ check(value) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "call from bad param value" { + error + require "call.+param #x" +} + +@value interface Base { + call () -> () +} + +define Test { + @type check<#x> + (#x) -> () + check (value) { + ~ value.call() + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "convert arg" { + success Test$run() +} + +@value interface Base { + call () -> () +} + +concrete Value { + refines Base + + @type create () -> (Value) +} + +define Value { + call () {} + + create () { + return Value{} + } +} + +define Test { + @type convert (Value) -> (Base) + convert (value) { + return value + } + + run () { + ~ convert(Value$create()).call() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "bad convert arg" { + error + require "does not refine Value" +} + +@value interface Base {} + +concrete Value {} + +define Value {} + +define Test { + @type convert (Base) -> (Value) + convert (value) { + return value + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "bad instance in param" { + error + require "Test" + require "define" + require "Equals" +} + +@value interface Value<#x> { + #x defines Equals<#x> +} + +concrete Call { + @type call<#x> () -> () +} + +define Call { + call () {} +} + +define Test { + run () { + ~ Call$call>() + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/function-merging.0rt b/tests/function-merging.0rt new file mode 100644 --- /dev/null +++ b/tests/function-merging.0rt @@ -0,0 +1,150 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "internal merge" { + success Test$run() +} + +@value interface Interface { + call () -> (Interface) +} + +concrete Value { + refines Interface + @type create () -> (Value) +} + +define Value { + create () { + return Value{} + } + + @value call () -> (Value) + call () { + return self + } +} + +define Test { + run () { + ~ Value$create().call().call() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "internal merge failed" { + error + require "Interface2" +} + +@value interface Interface {} + +@value interface Interface2 { + refines Interface + call () -> (Interface2) +} + +concrete Value { + refines Interface2 + @type create () -> (Value) +} + +define Value { + create () { + return Value{} + } + + @value call () -> (Interface) + call () { + return self + } +} + +define Test { + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "external merge" { + success Test$run() +} + +@value interface Interface { + call () -> (Interface) +} + +concrete Value { + refines Interface + @type create () -> (Value) + @value call () -> (Value) +} + +define Value { + create () { + return Value{} + } + + call () { + return self + } +} + +define Test { + run () { + ~ Value$create().call().call() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "external merge failed" { + error + require "Interface2" +} + +@value interface Interface {} + +@value interface Interface2 { + refines Interface + call () -> (Interface2) +} + +concrete Value { + refines Interface2 + @type create () -> (Value) + @value call () -> (Interface) +} + +define Test { + run () {} +} + +concrete Test { + @type run () -> () +} diff --git a/tests/infix-functions.0rt b/tests/infix-functions.0rt new file mode 100644 --- /dev/null +++ b/tests/infix-functions.0rt @@ -0,0 +1,164 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "category infix" { + success Test$run() +} + +define Test { + @category add (Int,Int) -> (Int) + add (x,y) { + return x + y + } + + run () { + Int value <- 1 `Test$$add` 2 + if (value != 3) { + fail(value) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "type infix" { + success Test$run() +} + +define Test { + @type add (Int,Int) -> (Int) + add (x,y) { + return x + y + } + + run () { + Int value <- 1 `Test$add` 2 + if (value != 3) { + fail(value) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "value infix" { + success Test$run() +} + +concrete Arithmetic { + @type create () -> (Arithmetic) + @value add (Int,Int) -> (Int) +} + +define Arithmetic { + create () { + return Arithmetic{ } + } + + add (x,y) { + return x + y + } +} + +define Test { + run () { + Int value <- 1 `Arithmetic$create().add` 2 + if (value != 3) { + fail(value) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "unqualified infix" { + success Test$run() +} + +define Test { + @type add (Int,Int) -> (Int) + add (x,y) { + return x + y + } + + run () { + Int value <- 1 `add` 2 + if (value != 3) { + fail(value) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "infix function comes after arithmetic" { + success Test$run() +} + +define Test { + @category add (Int,Int) -> (Int) + add (x,y) { + return x + y + } + + run () { + Int value <- 1 `add` 2 * 3 + if (value != 7) { + fail(value) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "infix function comes before comparison" { + success Test$run() +} + +define Test { + @category add (Int,Int) -> (Int) + add (x,y) { + return x + y + } + + run () { + Bool value <- 1 `add` 2 < 4 + if (value != true) { + fail(value) + } + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/infix-operations.0rt b/tests/infix-operations.0rt new file mode 100644 --- /dev/null +++ b/tests/infix-operations.0rt @@ -0,0 +1,375 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "Int arithmetic with precedence" { + success Test$run() +} + +define Test { + run () { + scoped { + Int x <- \x10 + 1 * 2 - 8 / 2 - 3 % 2 + } in if (x != 13) { + fail(x) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "same operators applied left to right" { + success Test$run() +} + +define Test { + run () { + scoped { + Int x <- 2 - 1 - 1 + } in if (x != 0) { + fail(x) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Int + Bool" { + error + require "Int.+Bool" +} + +define Test { + run () { + ~ \x10 + false + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Int + String" { + error + require "Int.+String" +} + +define Test { + run () { + ~ \x10 + "" + } +} + +concrete Test { + @type run () -> () +} + + +testcase "String arithmetic" { + success Test$run() +} + +define Test { + run () { + scoped { + String x <- "x" + "y" + "z" + } in if (x != "xyz") { + fail(x) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Float arithmetic with precedence" { + success Test$run() +} + +define Test { + run () { + scoped { + Float x <- 16.0 + 1.0 * 2.0 - 8.0 / 2.0 - 3.0 / 3.0 + } in if (x != 13.0) { + fail(x) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Bool comparison" { + success Test$run() +} + +define Test { + run () { + if (!(true == true)) { fail("Failed") } + if (!(false == false)) { fail("Failed") } + if (!(false != true)) { fail("Failed") } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Int comparison" { + success Test$run() +} + +define Test { + run () { + if (!(1 < 2)) { fail("Failed") } + if (!(1 <= 2)) { fail("Failed") } + if (!(1 == 1)) { fail("Failed") } + if (!(1 != 2)) { fail("Failed") } + if (!(2 > 1)) { fail("Failed") } + if (!(2 >= 1)) { fail("Failed") } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Float comparison" { + success Test$run() +} + +define Test { + run () { + if (!(1.0 < 2.0)) { fail("Failed") } + if (!(1.0 <= 2.0)) { fail("Failed") } + if (!(1.0 == 1.0)) { fail("Failed") } + if (!(1.0 != 2.0)) { fail("Failed") } + if (!(2.0 > 1.0)) { fail("Failed") } + if (!(2.0 >= 1.0)) { fail("Failed") } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "String comparison" { + success Test$run() +} + +define Test { + run () { + if (!("x" < "y")) { fail("Failed") } + if (!("x" <= "y")) { fail("Failed") } + if (!("x" == "x")) { fail("Failed") } + if (!("x" != "y")) { fail("Failed") } + if (!("y" > "x")) { fail("Failed") } + if (!("y" >= "x")) { fail("Failed") } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Char comparison" { + success Test$run() +} + +define Test { + run () { + if (!('x' < 'y')) { fail("Failed") } + if (!('x' <= 'y')) { fail("Failed") } + if (!('x' == 'x')) { fail("Failed") } + if (!('x' != 'y')) { fail("Failed") } + if (!('y' > 'x')) { fail("Failed") } + if (!('y' >= 'x')) { fail("Failed") } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Bool logic with precedence" { + success Test$run() +} + +define Test { + run () { + scoped { + Bool x <- false && false || true + } in if (!x) { + fail(x) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "minus String" { + error + require "String.+String" +} + +define Test { + run () { + ~ "x" - "x" + } +} + +concrete Test { + @type run () -> () +} + + +testcase "arithmetic Bool" { + error + require "Bool.+Bool" +} + +define Test { + run () { + ~ true - false + } +} + +concrete Test { + @type run () -> () +} + + +testcase "String plus with comparison" { + success Test$run() +} + +define Test { + run () { + if (!("x" + "w" < "x" + "y")) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Char minus with comparison" { + success Test$run() +} + +define Test { + run () { + if (!('d' - 'a' == 3)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Int arithmetic with comparison" { + success Test$run() +} + +define Test { + run () { + if (!(2 + 1 < 2 + 3)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Float arithmetic with comparison" { + success Test$run() +} + +define Test { + run () { + if (!(2.0 + 1.0 < 2.0 + 3.0)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Bool comparison" { + error + require "Bool.+Int" +} + +define Test { + run () { + ~ 1 < 2 < 3 + } +} + +concrete Test { + @type run () -> () +} + + +testcase "arithmetic, comparison, logic" { + success Test$run() +} + +define Test { + run () { + scoped { + Bool x <- 1 + 2 < 4 && 3 >= 1 * 2 + 1 + } in if (!x) { + fail(x) + } + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/internal-inheritance.0rt b/tests/internal-inheritance.0rt new file mode 100644 --- /dev/null +++ b/tests/internal-inheritance.0rt @@ -0,0 +1,220 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "internal category types are checked" { + error + require "Formatted" + require "type interface" +} + +concrete Value { + @type create () -> (Value) +} + +define Value { + defines Formatted +} + + +testcase "internal refine is private" { + success Test$run() +} + +concrete Value { + @type create () -> (Value) + @value get () -> (Formatted) +} + +define Value { + refines Formatted + + create () { + return Value{ } + } + + get () { + return self + } + + formatted () { + return "Value" + } +} + +define Test { + run () { + String value <- Value$create().get().formatted() + if (value != "Value") { + fail(value) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "internal refine is not public" { + error + require "refine" + require "Formatted" + require "Value" +} + +concrete Value { + @type create () -> (Value) +} + +define Value { + refines Formatted + + create () { + return Value{ } + } + + formatted () { + return "Value" + } +} + +define Test { + run () { + Formatted value <- Value$create() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "internal define is private" { + success Test$run() +} + +concrete Compare<#x> { + #x defines Equals<#x> + + @type compare (#x,#x) -> (Bool) +} + +define Compare { + compare (x,y) { + return #x$equals(x,y) + } +} + +concrete Value { + @type create (Int) -> (Value) + @type compare (Value,Value) -> (Bool) +} + +define Value { + defines Equals + + @value Int value + + equals (x,y) { + return x.get() == y.get() + } + + create (x) { + return Value{ x } + } + + compare (x,y) { + return Compare$compare(x,y) + } + + @value get () -> (Int) + get () { + return value + } +} + +define Test { + run () { + Value value1 <- Value$create(1) + Value value2 <- Value$create(2) + if (Value$compare(value1,value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "internal define is not public" { + error + require "define" + require "Equals" + require "Value" +} + +concrete Compare<#x> { + #x defines Equals<#x> + + @type compare (#x,#x) -> (Bool) +} + +define Compare { + compare (x,y) { + return #x$equals(x,y) + } +} + +concrete Value { + @type create (Int) -> (Value) +} + +define Value { + defines Equals + + @value Int value + + equals (x,y) { + return x.get() == y.get() + } + + create (x) { + return Value{ x } + } + + @value get () -> (Int) + get () { + return value + } +} + +define Test { + run () { + Value value1 <- Value$create(1) + Value value2 <- Value$create(2) + if (Compare$compare(value1,value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/internal-params.0rt b/tests/internal-params.0rt new file mode 100644 --- /dev/null +++ b/tests/internal-params.0rt @@ -0,0 +1,474 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "internal param not visible from @type" { + error + require "#x" +} + +concrete Value {} + +define Value { + types<#x> {} + + @type something () -> () + something () { + optional #x val <- empty + } +} + +define Test { + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "internal filter not applied in @type" { + success Test$run() +} + +concrete Value { + @type something<#x> () -> () +} + +define Value { + types<#x> { + #x defines LessThan<#x> + } + + something () {} +} + +define Test { + run () { + ~ Value$something() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "internal filter not applied in @category" { + success Test$run() +} + +concrete Value { + @category something<#x> () -> () +} + +define Value { + types<#x> { + #x defines LessThan<#x> + } + + something () {} +} + +define Test { + run () { + ~ Value$$something() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "internal params" { + success Test$run() +} + +concrete Value { + @type create<#x,#y> + () -> (Value) +} + +define Value { + types<#x,#y> {} + + create () { + return Value{ types<#x,#y> } + } +} + +@value interface Type1 {} +@value interface Type2 {} + +define Test { + run () { + ~ Value$create() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "internal params with filters" { + success Test$run() +} + +@value interface Get<|#x> { + get () -> (#x) +} + +@value interface Set<#x|> { + set (#x) -> () +} + +concrete Value { + @type create<#x,#y> + #x requires Get<#x> + #y allows Set<#y> + () -> (Value) +} + +define Value { + types<#x,#y> { + #x requires Get<#x> + #y allows Set<#y> + } + + create () { + return Value{ types<#x,#y> } + } +} + +define Test { + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "internal params missing filters" { + error + require "Get|Set" +} + +@value interface Get<|#x> { + get () -> (#x) +} + +@value interface Set<#x|> { + set (#x) -> () +} + +concrete Value { + @category create<#x,#y> + () -> (Value) +} + +define Value { + types<#x,#y> { + #x requires Get<#x> + #y allows Set<#y> + } + + create () { + return Value{ types<#x,#y> } + } +} + +define Test { + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "internal params with values" { + success Test$run() +} + +concrete Value { + @category create<#x,#y> + () -> (Value) +} + +define Value { + types<#x,#y> {} + + @value Bool value + + create () { + return Value{ types<#x,#y>, false } + } +} + +define Test { + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "value depends on internal param" { + success Test$run() +} + +concrete Type<#y> { + @type create () -> (Type<#y>) +} + +define Type { + create () { + return Type<#y>{} + } +} + +concrete Value { + @type create<#x> + (Type<#x>) -> (Value) +} + +define Value { + types<#z> {} + + @value Type<#z> value + + create (value) { + return Value{ types<#x>, value } + } +} + +define Test { + run () { + ~ Value$create(Type$create()) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "value mismatch with internal param" { + error + require "call" + require "Bool" + require "String" +} + +concrete Type<#y> { + @type create () -> (Type<#y>) +} + +define Type { + create () { + return Type<#y>{} + } +} + +concrete Value { + @type create<#x> + (Type<#x>) -> (Value) +} + +define Value { + types<#z> {} + + @value Type<#z> value + + create (value) { + return Value{ types<#x>, value } + } +} + +define Test { + run () { + ~ Value$create(Type$create()) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "internal param clash with external" { + error + require "#x" +} + +concrete Value<#x> {} + +define Value { + types<#x> {} +} + +define Test { + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "internal param clash with function" { + error + require "#x" +} + +concrete Value { + @value check<#x> () -> () +} + +define Value { + types<#x> {} +} + +define Test { + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "internal param clash with internal function" { + error + require "#x" +} + +concrete Value {} + +define Value { + types<#x> {} + + @value check<#x> () -> () + check () {} +} + +define Test { + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "internal param no clash with category" { + success Test$run() +} + +concrete Value { + @category create<#x> () -> (Value) +} + +define Value { + types<#x> {} + + create () { + return Value { types<#x> } + } +} + +define Test { + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce internal param success" { + success Test$run() +} + +concrete Value { + @type create<#x> () -> (Value) + @value check<#y> (#y) -> (Bool) +} + +define Value { + types<#x> {} + + create () { + return Value { types<#x> } + } + + check (y) { + return present(reduce<#y,#x>(y)) + } +} + +define Test { + run () { + Value value <- Value$create() + if (!value.check("")) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce internal param fail" { + success Test$run() +} + +concrete Value { + @type create<#x> () -> (Value) + @value check<#y> (#y) -> (Bool) +} + +define Value { + types<#x> {} + + create () { + return Value { types<#x> } + } + + check (y) { + return present(reduce<#y,#x>(y)) + } +} + +define Test { + run () { + Value value <- Value$create() + if (value.check(value)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/member-init.0rt b/tests/member-init.0rt new file mode 100644 --- /dev/null +++ b/tests/member-init.0rt @@ -0,0 +1,303 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "@type member not allowed" { + error + require "not allowed" +} + +define Test { + @type Bool value <- false + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "@category member from @type" { + success Test$run() +} + +define Test { + @category Bool value <- true + + @type call () -> () + call () { + ~ value + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "@category member from @value" { + success Test$run() +} + +define Test { + @category Bool value <- true + + @value call () -> () + call () { + ~ value + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "@category to @category" { + error + require "get" +} + +define Test { + @category Bool value <- get() + + @category get () -> (Bool) + get () { + return true + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "@category member is lazy" { + success Test$run() +} + +concrete Util { + @type doNotUse () -> (Bool) +} + +define Util { + doNotUse () { + fail("do not use") + } +} + +define Test { + @category Bool value <- Util$doNotUse() + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "@category member init when read" { + crash Test$run() + require "do not use" +} + +concrete Util { + @type doNotUse () -> (Bool) +} + +define Util { + doNotUse () { + fail("do not use") + } +} + +define Test { + @category Bool value <- Util$doNotUse() + + run () { + Bool value2 <- value + } +} + +concrete Test { + @type run () -> () +} + + +testcase "@category member init when assigned" { + crash Test$run() + require "do not use" +} + +concrete Util { + @type doNotUse () -> (Bool) +} + +define Util { + doNotUse () { + fail("do not use") + } +} + +define Test { + @category Bool value <- Util$doNotUse() + + run () { + value <- false + } +} + +concrete Test { + @type run () -> () +} + + +testcase "@category member init when ignored" { + crash Test$run() + require "do not use" +} + +concrete Util { + @type doNotUse () -> (Bool) +} + +define Util { + doNotUse () { + fail("do not use") + } +} + +define Test { + @category Bool value <- Util$doNotUse() + + run () { + ~ value + } +} + +concrete Test { + @type run () -> () +} + + +testcase "@category member inline assignment" { + success Test$run() +} + +define Test { + @category Bool value <- true + + @type call () -> (Bool) + call () { + return (value <- false) + } + + run () { + if (call() || value) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "@category init cycle" { + crash Test$run() + require "Value1|Value2" +} + +concrete Value1 { + @type get () -> (Bool) +} + +concrete Value2 { + @type get () -> (Bool) +} + +define Value1 { + @category Bool value <- Value2$get() + + get () { + return value + } +} + +define Value2 { + @category Bool value <- Value1$get() + + get () { + return value + } +} + +define Test { + run () { + ~ Value1$get() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "self in @category init" { + error + require "self" +} + +define Test { + @category Test value <- self + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "cycle in @category init" { + error + require "disallowed" +} + +define Test { + @category Bool value <- get() + + @category get () -> (Bool) + get () { + return value + } + + run () {} +} + +concrete Test { + @type run () -> () +} diff --git a/tests/modifed-storage.0rt b/tests/modifed-storage.0rt new file mode 100644 --- /dev/null +++ b/tests/modifed-storage.0rt @@ -0,0 +1,268 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "optional persists" { + success Test$run() +} + +define Test { + @value optional Test self2 + + @type create () -> (Test) + create () { + return Test{ empty } + } + + @value set () -> () + set () { + scoped { + Test value <- create() + } in self2 <- value + } + + @value check () -> () + check () { + ~ require(self2) + } + + run () { + Test value <- create() + ~ value.set() + ~ value.check() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "weak is weak" { + success Test$run() +} + +define Test { + @value weak Test self2 + + @type create () -> (Test) + create () { + return Test{ empty } + } + + @value set () -> () + set () { + scoped { + Test value <- create() + } in self2 <- value + } + + @value check () -> () + check () { + scoped { + optional Test self3 <- strong(self2) + } in if (present(self3)) { + fail("Failed") + } + } + + run () { + Test value <- create() + ~ value.set() + ~ value.check() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "present weak" { + success Test$run() +} + +define Test { + @type create () -> (Test) + create () { + return Test{} + } + + @value check () -> () + check () { + weak Test value <- create() + if (present(strong(value))) { // value should be nullptr here + fail("Failed") + } + } + + run () { + Test value <- create() + ~ value.check() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "weak variable to weak variable" { + success Test$run() +} + +define Test { + @category weak Test one <- empty + + run () { + weak Test two <- one + one <- two + } +} + +concrete Test { + @type run () -> () +} + + +testcase "optional variable to weak variable" { + success Test$run() +} + +define Test { + @category optional Test one <- empty + + run () { + weak Test two <- one + two <- one + } +} + +concrete Test { + @type run () -> () +} + + +testcase "weak in multi assign" { + success Test$run() +} + +concrete Value { + @type create () -> (Value) +} + +define Value { + create () { + return Value{} + } +} + +define Test { + @type get () -> (Value,Value) + get () { + Value value <- Value$create() + return { value, value } + } + + run () { + // value1 ensures value2 is present. + { Value value1, weak Value value2 } <- get() + if (!present(strong(value2))) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "weak in inline assign" { + success Test$run() +} + +concrete Value { + @type create () -> (Value) +} + +define Value { + create () { + return Value{} + } +} + +define Test { + run () { + Value value1 <- Value$create() + weak Value value2 <- empty + if (!present(strong((value2 <- value1)))) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "present required" { + success Test$run() +} + +define Test { + @type create () -> (Test) + create () { + return Test{} + } + + run () { + Test value <- create() + if (!present(value)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "require required" { + success Test$run() +} + +define Test { + @type create () -> (Test) + create () { + return Test{} + } + + @value call () -> () + call () {} + + run () { + Test value <- create() + ~ require(value).call() + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/multiple-defs/.zeolite-module b/tests/multiple-defs/.zeolite-module new file mode 100644 --- /dev/null +++ b/tests/multiple-defs/.zeolite-module @@ -0,0 +1,1 @@ +RecompileMetadata {rmRoot = "../..", rmPath = "tests/multiple-defs", rmPublicDeps = [], rmPrivateDeps = [], rmExtraFiles = [], rmExtraPaths = [], rmExtraRequires = [], rmMode = CompileIncremental, rmOutputName = ""} diff --git a/tests/multiple-defs/README.md b/tests/multiple-defs/README.md new file mode 100644 --- /dev/null +++ b/tests/multiple-defs/README.md @@ -0,0 +1,19 @@ +# Multiple Definition Failure + +Compiling this module should **always fail**. It tests a compiler check that +ensures that multiple `.0rx` files do not define the same `concrete` category +from a `.0rp` file. + +To compile: + +```shell +../../zeolite -r . +``` + +The compiler error should look something like this: + +```text +Public category Type ["tests/multiple-defs/public.0rp" (line 19, column 1)] is defined 2 times + Defined at "tests/multiple-defs/private2.0rx" (line 19, column 1) + Defined at "tests/multiple-defs/private1.0rx" (line 19, column 1) +``` diff --git a/tests/multiple-defs/private1.0rx b/tests/multiple-defs/private1.0rx new file mode 100644 --- /dev/null +++ b/tests/multiple-defs/private1.0rx @@ -0,0 +1,19 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +define Type {} diff --git a/tests/multiple-defs/private2.0rx b/tests/multiple-defs/private2.0rx new file mode 100644 --- /dev/null +++ b/tests/multiple-defs/private2.0rx @@ -0,0 +1,19 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +define Type {} diff --git a/tests/multiple-defs/public.0rp b/tests/multiple-defs/public.0rp new file mode 100644 --- /dev/null +++ b/tests/multiple-defs/public.0rp @@ -0,0 +1,19 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +concrete Type {} diff --git a/tests/multiple-returns.0rt b/tests/multiple-returns.0rt new file mode 100644 --- /dev/null +++ b/tests/multiple-returns.0rt @@ -0,0 +1,142 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "multi return to call" { + error + require "call.+\{Value,Value\}" +} + +@value interface Value { + get () -> (Value,Value) + call () -> () +} + +define Test { + @value process (Value) -> () + process (value) { + ~ value.get().call() + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "zero return to call" { + error + require "call.+\{\}" +} + +@value interface Value { + get () -> () + call () -> () +} + +define Test { + @value process (Value) -> () + process (value) { + ~ value.get().call() + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "multi return assign" { + success Test$run() +} + +define Test { + @type create () -> (Test) + create () { + return Test{} + } + + @value double () -> (Test,Test) + double () { + return { self, self } + } + + run () { + Test value <- create() + { _, Test value2 } <- value.double() + { value, _ } <- value2.double() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "multi return as args" { + success Test$run() +} + +define Test { + @type get () -> (Int,Int) + get () { + return { 1, 2 } + } + + @type call (Int,Int) -> () + call (x,y) { + if (x != 1) { + fail("Failed") + } + if (y != 2) { + fail("Failed") + } + } + + run () { + ~ call(get()) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "empty return is not return with assignments" { + error + require "count.+mismatch" +} + +define Test { + @type process () -> (Int,Int) + process () (x,y) { + x <- 1 + y <- 2 + return { } + } + + run () {} +} + +concrete Test { + @type run () -> () +} diff --git a/tests/named-returns.0rt b/tests/named-returns.0rt new file mode 100644 --- /dev/null +++ b/tests/named-returns.0rt @@ -0,0 +1,244 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "missing assign" { + error + require "value" +} + +@value interface Value {} + +define Test { + @value process () -> (Value) + process () (value) {} + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "assign before logical" { + success Test$run() +} + +define Test { + @value process () -> (Bool) + process () (value) { + ~ (value <- true) || false + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "assign after logical" { + error + require "value" +} + +define Test { + @value process () -> (Bool) + process () (value) { + ~ false || (value <- true) + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "assign before arithmetic" { + success Test$run() +} + +define Test { + @value process () -> (Int) + process () (value) { + ~ (value <- 1) + 2 + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "assign after arithmetic" { + success Test$run() +} + +define Test { + @value process () -> (Int) + process () (value) { + ~ 2 + (value <- 1) + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "return used before assigned" { + error + require "value.+initialized" +} + +define Test { + @category process () -> (Int) + process () (value) { + value <- value+1 + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "return used after assigned" { + success Test$run() +} + +define Test { + @category process () -> (Int) + process () (value) { + value <- 1 + value <- value+1 + } + + run () { + Int value <- process() + if (value != 2) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "returns in correct order" { + success Test$run() +} + +define Test { + @type get () -> (Int,Int) + get () { + return { 1, 2 } + } + + run () { + scoped { + { Int x, Int y } <- get() + } in if (x != 1) { + fail("Failed") + } elif (y != 2) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "assigns in correct order" { + success Test$run() +} + +concrete Value { + @type create () -> (Value) +} + +define Value { + create () { + return Value{} + } +} + +define Test { + @type get () -> (Value,Int,Int) + get () (v,x,y) { + // This makes sure that x and y (primitive) are offset. + v <- Value$create() + x <- 1 + y <- 2 + } + + run () { + scoped { + { _, Int x, Int y } <- get() + } in if (x != 1) { + fail("Failed") + } elif (y != 2) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "assigns in correct order with explicit return" { + success Test$run() +} + +define Test { + @type get () -> (Int,Int) + get () (x,y) { + x <- 1 + y <- 2 + return _ + } + + run () { + scoped { + { Int x, Int y } <- get() + } in if (x != 1) { + fail("Failed") + } elif (y != 2) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/positional-returns.0rt b/tests/positional-returns.0rt new file mode 100644 --- /dev/null +++ b/tests/positional-returns.0rt @@ -0,0 +1,123 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "missing return" { + error + require "Value" +} + +@value interface Value {} + +define Test { + @value process () -> (Value) + process () {} + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "positional return with no names assigned" { + success Test$run() +} + +define Test { + @type get () -> (Int,Int) + get () (x,y) { + if (false) { + x <- 1 + } else { + return { 3, 4 } + } + y <- 2 + } + + run () { + scoped { + { Int x, Int y } <- get() + } in if (x != 3) { + fail("Failed") + } elif (y != 4) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "positional return instead of names" { + success Test$run() +} + +define Test { + @type get () -> (Int,Int) + get () (x,y) { + return { 1, 2 } + } + + run () { + scoped { + { Int x, Int y } <- get() + } in if (x != 1) { + fail("Failed") + } elif (y != 2) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "positional return with some names assigned" { + success Test$run() +} + +define Test { + @type get () -> (Int,Int) + get () (x,y) { + y <- 2 + if (false) { + x <- 1 + } else { + return { 3, 4 } + } + } + + run () { + scoped { + { Int x, Int y } <- get() + } in if (x != 3) { + fail("Failed") + } elif (y != 4) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/reduce.0rt b/tests/reduce.0rt new file mode 100644 --- /dev/null +++ b/tests/reduce.0rt @@ -0,0 +1,828 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "reduce to self" { + success Test$run() +} + +concrete Value { + @type create () -> (Value) +} + +define Value { + create () { + return Value{} + } +} + +define Test { + run () { + Value value <- Value$create() + scoped { + optional Value value2 <- reduce(value) + } in if (!present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce to unrelated" { + success Test$run() +} + +concrete Value { + @type create () -> (Value) +} + +define Value { + create () { + return Value{} + } +} + +define Test { + run () { + Value value <- Value$create() + scoped { + optional Test value2 <- reduce(value) + } in if (present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce wrong arg type" { + error + require "argument" +} + +concrete Value { + @type create () -> (Value) +} + +define Value { + create () { + return Value{} + } +} + +define Test { + run () { + Value value <- Value$create() + optional Value value2 <- reduce(value) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce wrong return type" { + error + require "assignment" +} + +concrete Value { + @type create () -> (Value) +} + +define Value { + create () { + return Value{} + } +} + +define Test { + run () { + Value value <- Value$create() + optional Value value2 <- reduce(value) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce success with param" { + success Test$run() +} + +concrete Value<|#x> { + @type create () -> (Value<#x>) + + @value attempt<#y> + () -> (optional Value<#y>) +} + +define Value { + create () { + return Value<#x>{} + } + + attempt () { + return reduce,Value<#y>>(self) + } +} + +@value interface Type1 {} + +@value interface Type2 { + refines Type1 +} + +define Test { + run () { + Value value <- Value$create() + scoped { + optional Value value2 <- value.attempt() + } in if (!present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce fail with param" { + success Test$run() +} + +concrete Value<|#x> { + @type create () -> (Value<#x>) + + @value attempt<#y> + () -> (optional Value<#y>) +} + +define Value { + create () { + return Value<#x>{} + } + + attempt () { + return reduce,Value<#y>>(self) + } +} + +@value interface Type1 {} + +@value interface Type2 { + refines Type1 +} + +define Test { + run () { + Value value <- Value$create() + scoped { + optional Value value2 <- value.attempt() + } in if (present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce success with contra param" { + success Test$run() +} + +concrete Value<#x|> { + @type create () -> (Value<#x>) + + @value attempt<#y> + () -> (optional Value<#y>) +} + +define Value { + create () { + return Value<#x>{} + } + + attempt () { + return reduce,Value<#y>>(self) + } +} + +@value interface Type1 {} + +@value interface Type2 { + refines Type1 +} + +define Test { + run () { + Value> value <- Value>$create() + scoped { + optional Value> value2 <- value.attempt>() + } in if (!present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce fail with contra param" { + success Test$run() +} + +concrete Value<#x|> { + @type create () -> (Value<#x>) + + @value attempt<#y> + () -> (optional Value<#y>) +} + +define Value { + create () { + return Value<#x>{} + } + + attempt () { + return reduce,Value<#y>>(self) + } +} + +@value interface Type1 {} + +@value interface Type2 { + refines Type1 +} + +define Test { + run () { + Value> value <- Value>$create() + scoped { + optional Value> value2 <- value.attempt>() + } in if (present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce success from union" { + success Test$run() +} + +@value interface Base {} + +concrete Value1 { + refines Base + + @type create () -> (Value1) +} + +define Value1 { + create () { + return Value1{} + } +} + +@value interface Value2 { + refines Base +} + +define Test { + run () { + [Value1|Value2] value <- Value1$create() + scoped { + optional Base value2 <- reduce<[Value1|Value2],Base>(value) + } in if (!present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce fail from union" { + success Test$run() +} + +@value interface Base {} + +concrete Value1 { + refines Base + + @type create () -> (Value1) +} + +define Value1 { + create () { + return Value1{} + } +} + +@value interface Value2 { + refines Base +} + +define Test { + run () { + [Value1|Value2] value <- Value1$create() + scoped { + optional Value2 value2 <- reduce<[Value1|Value2],Value2>(value) + } in if (present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce success to intersect" { + success Test$run() +} + +@value interface Base1 {} + +@value interface Base2 {} + +concrete Value { + refines Base1 + refines Base2 + + @type create () -> (Value) +} + +define Value { + create () { + return Value{} + } +} + +define Test { + run () { + Value value <- Value$create() + scoped { + optional [Base1&Base2] value2 <- reduce(value) + } in if (!present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce fail to intersect" { + success Test$run() +} + +@value interface Base1 {} + +@value interface Base2 {} + +concrete Value { + refines Base1 + + @type create () -> (Value) +} + +define Value { + create () { + return Value{} + } +} + +define Test { + run () { + Value value <- Value$create() + scoped { + optional [Base1&Base2] value2 <- reduce(value) + } in if (present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce success union to intersect" { + success Test$run() +} + +@value interface Base1 {} + +@value interface Base2 {} + +@value interface Value1 { + refines Base1 + refines Base2 +} + +concrete Value2 { + refines Base1 + refines Base2 + + @type create () -> (Value2) +} + +define Value2 { + create () { + return Value2{} + } +} + +define Test { + run () { + [Value1|Value2] value <- Value2$create() + scoped { + optional [Base1&Base2] value2 <- reduce<[Value1|Value2],[Base1&Base2]>(value) + } in if (!present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce fail union to intersect" { + success Test$run() +} + +@value interface Base1 {} + +@value interface Base2 {} + +@value interface Value1 { + refines Base1 + refines Base2 +} + +concrete Value2 { + refines Base1 + + @type create () -> (Value2) +} + +define Value2 { + create () { + return Value2{} + } +} + +define Test { + run () { + [Value1|Value2] value <- Value2$create() + scoped { + optional [Base1&Base2] value2 <- reduce<[Value1|Value2],[Base1&Base2]>(value) + } in if (present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce success intersect to union" { + success Test$run() +} + +@value interface Base1 {} + +@value interface Base2 {} + +@value interface Value1 { + refines Base1 +} + +@value interface Value2 {} + +concrete Data { + refines Value1 + refines Value2 + + @type create () -> (Data) +} + +define Data { + create () { + return Data{} + } +} + +define Test { + run () { + [Value1&Value2] value <- Data$create() + scoped { + optional [Base1|Base2] value2 <- reduce<[Value1&Value2],[Base1|Base2]>(value) + } in if (!present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce fail intersect to union" { + success Test$run() +} + +@value interface Base1 {} + +@value interface Base2 {} + +@value interface Value1 {} + +@value interface Value2 {} + +concrete Data { + refines Value1 + refines Value2 + + @type create () -> (Data) +} + +define Data { + create () { + return Data{} + } +} + +define Test { + run () { + [Value1&Value2] value <- Data$create() + scoped { + optional [Base1|Base2] value2 <- reduce<[Value1&Value2],[Base1|Base2]>(value) + } in if (present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce succeeds to covariant any" { + success Test$run() +} + +concrete Value<|#x> { + @type create () -> (Value<#x>) +} + +define Value { + create () { + return Value<#x>{} + } +} + +define Test { + run () { + Value value <- Value$create() + scoped { + optional Value value2 <- reduce,Value>(value) + } in if (!present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce succeeds to contravariant all" { + success Test$run() +} + +concrete Value<#x|> { + @type create () -> (Value<#x>) +} + +define Value { + create () { + return Value<#x>{} + } +} + +define Test { + run () { + Value value <- Value$create() + scoped { + optional Value value2 <- reduce,Value>(value) + } in if (!present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce fails to invariant any" { + success Test$run() +} + +concrete Value<#x> { + @type create () -> (Value<#x>) +} + +define Value { + create () { + return Value<#x>{} + } +} + +define Test { + run () { + Value value <- Value$create() + scoped { + optional Value value2 <- reduce,Value>(value) + } in if (present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce succeeds from covariant all" { + success Test$run() +} + +concrete Value<|#x> { + @type create () -> (Value<#x>) +} + +define Value { + create () { + return Value<#x>{} + } +} + +define Test { + run () { + Value value <- Value$create() + scoped { + optional Value value2 <- reduce,Value>(value) + } in if (!present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce succeeds from contravariant any" { + success Test$run() +} + +concrete Value<#x|> { + @type create () -> (Value<#x>) +} + +define Value { + create () { + return Value<#x>{} + } +} + +define Test { + run () { + Value value <- Value$create() + scoped { + optional Value value2 <- reduce,Value>(value) + } in if (!present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "reduce fails from invariant all" { + success Test$run() +} + +concrete Value<#x> { + @type create () -> (Value<#x>) +} + +define Value { + create () { + return Value<#x>{} + } +} + +define Test { + run () { + Value value <- Value$create() + scoped { + optional Value value2 <- reduce,Value>(value) + } in if (present(value2)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "bad instance in reduce param" { + error + require "Test" + require "define" + require "Equals" +} + +@value interface Value<#x> { + #x defines Equals<#x> +} + +concrete Call { + @type call<#x> () -> () +} + +define Call { + call () {} +} + +define Test { + run () { + ~ reduce,Formatted>(empty) + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/scoped.0rt b/tests/scoped.0rt new file mode 100644 --- /dev/null +++ b/tests/scoped.0rt @@ -0,0 +1,667 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "scoped unconditional" { + success Test$run() +} + +@value interface Value {} + +define Test { + run () { + scoped { + Int x <- 1 + } in { + x <- 2 + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "unconditional has scoping" { + error + require "x" +} + +@value interface Value {} + +define Test { + run () { + scoped { + } in { + Int x <- 1 + } + x <- 2 + } +} + +concrete Test { + @type run () -> () +} + + +testcase "return inside scope" { + success Test$run() +} + + +@value interface Value {} + +define Test { + @value process () -> (optional Value) + process () { + scoped { + return empty + } in ~ empty + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "return from scoped" { + success Test$run() +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value) + process () { + scoped { + } in return empty + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "update clashes with scoped" { + error + require "x" +} + +define Test { + run () { + scoped { + Int x <- 2 + } in while (false) { + } update { + Int x <- 1 + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "assign inside scope" { + success Test$run() +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value) + process () (value) { + scoped { + value <- empty + } in ~ empty + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "assign from scoped" { + success Test$run() +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value) + process () (value) { + scoped { + } in value <- empty + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "simple cleanup" { + success Test$run() +} + +define Test { + run () { + Int value <- 0 + scoped { + value <- 1 + } cleanup { + value <- 2 + } in value <- 3 + if (value != 2) { + fail(value) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "name clash in cleanup" { + error + require "value.+already defined" +} + +define Test { + run () { + scoped { + Int value <- 1 + } cleanup { + Int value <- 2 + } in ~ empty + } +} + +concrete Test { + @type run () -> () +} + + +testcase "cleanup before return" { + success Test$run() +} + +concrete Value { + @type create () -> (Value) + @value call () -> (Int) + @value get () -> (Int) +} + +define Value { + @value Int value + + create () { + return Value{ 0 } + } + + call () { + value <- 1 + scoped { + value <- 2 + } cleanup { + value <- 3 + } in return value + } + + get () { + return value + } +} + +define Test { + run () { + Value value <- Value$create() + Int value1 <- value.call() + if (value1 != 2) { + fail(value1) + } + Int value2 <- value.get() + if (value2 != 3) { + fail(value2) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "cleanup does not initialize return" { + error + require "value.+before return" +} + +define Test { + @type get () -> (Int) + get () (value) { + scoped { + } cleanup { + value <- 1 + } in return _ + } + + run () { + ~ get() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "cannot refer to cleanup variables" { + error + require "value.+not defined" +} + +define Test { + @type get () -> (Int) + get () (value) { + scoped { + } cleanup { + Int value2 <- 1 + } in return value2 + } + + run () { + ~ get() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "cleanup skipped in scoped return" { + success Test$run() +} + +define Test { + @type get () -> (Int) + get () { + Int value <- 0 + scoped { + value <- 1 + return value + } cleanup { + value <- 2 + } in return 3 + } + + run () { + Int value <- get() + if (value != 1) { + fail(value) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "no infinite loop in cleanup return" { + success Test$run() +} + +define Test { + @type get () -> (Int) + get () { + Int value <- 0 + scoped { + value <- 1 + } cleanup { + value <- 2 + return value + } in return 3 + } + + run () { + Int value <- get() + if (value != 2) { + fail(value) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "multiple cleanup" { + success Test$run() +} + +define Test { + run () { + Int value1 <- 0 + Int value2 <- 0 + Int value3 <- 0 + scoped { + } cleanup { + value1 <- 1 + value2 <- 1 + } in scoped { + } cleanup { + value2 <- 2 + value3 <- 2 + } in ~ empty + if (value1 != 1) { + fail(value1) + } + if (value2 != 1) { + fail(value2) + } + if (value3 != 2) { + fail(value3) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "multiple cleanup with return" { + success Test$run() +} + +concrete Value { + @type create () -> (Value) + @value call () -> (Int,Int,Int) + @value get () -> (Int,Int,Int) +} + +define Value { + @value Int value1 + @value Int value2 + @value Int value3 + + create () { + return Value{ 0, 0, 0 } + } + + call () { + value1 <- 1 + value2 <- 1 + value3 <- 1 + scoped { + } cleanup { + value1 <- 2 + value2 <- 2 + } in scoped { + } cleanup { + value2 <- 3 + value3 <- 3 + } in return { value1, value2, value3 } + } + + get () { + return { value1, value2, value3 } + } +} + +define Test { + run () { + Value value <- Value$create() + { Int value1, Int value2, Int value3 } <- value.call() + if (value1 != 1) { + fail(value1) + } + if (value2 != 1) { + fail(value2) + } + if (value3 != 1) { + fail(value3) + } + { value1, value2, value3 } <- value.get() + if (value1 != 2) { + fail(value1) + } + if (value2 != 2) { + fail(value2) + } + if (value3 != 3) { + fail(value3) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "cleanup cannot refer to later variables" { + error + require "value.+not defined" +} + +define Test { + run () { + scoped { + } cleanup { + value <- 1 + } in Int value <- 2 + } +} + +concrete Test { + @type run () -> () +} + + +testcase "cleanup not merged" { + error + require "value.+not defined" +} + +define Test { + run () { + scoped { + } cleanup { + Int value <- 0 + } in scoped { + } cleanup { + value <- 1 + } in ~ empty + } +} + +concrete Test { + @type run () -> () +} + + +testcase "no name clash in nested scope with return" { + success Test$run() +} + +define Test { + run () { + scoped { + } cleanup { + Int value <- 0 + } in scoped { + } cleanup { + Int value <- 1 + } in return _ + } +} + +concrete Test { + @type run () -> () +} + + +testcase "cleanup skipped for fail" { + crash Test$run() + require "scoped" +} + +define Test { + run () { + scoped { + String message <- "scoped" + } cleanup { + message <- "cleanup" + } in fail(message) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "cleanup not applied to returns outside of scope" { + success Test$run() +} + +define Test { + run () { + Int value <- 0 + scoped { + } cleanup { + if (value != 0) { + fail(value) + } + } in ~ empty + + value <- 1 + return _ + } +} + +concrete Test { + @type run () -> () +} + + +testcase "cleanup unconditional" { + success Test$run() +} + +@value interface Value {} + +define Test { + run () { + scoped { + Int x <- 1 + } in { + ~ x + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "just cleanup" { + success Test$run() +} + +concrete Value { + @type create () -> (Value) + @value postIncrement () -> (Int) + @value get () -> (Int) +} + +define Value { + @value Int value + + create () { + return Value{ 0 } + } + + postIncrement () { + cleanup { + value <- value+1 + } in return value + } + + get () { + return value + } +} + +define Test { + run () { + Value value <- Value$create() + Int value1 <- value.postIncrement() + if (value1 != 0) { + fail(value1) + } + Int value2 <- value.get() + if (value2 != 1) { + fail(value2) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "separate trace context for cleanup" { + crash Test$run() + require "Failed" + require "cleanup block" + require "Test\.run" + exclude "Failed.+Test\.run" + exclude "Test\.run.+Failed" +} + +define Test { + run () { + cleanup { + fail("Failed") + } in return _ + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/simple.0rt b/tests/simple.0rt new file mode 100644 --- /dev/null +++ b/tests/simple.0rt @@ -0,0 +1,73 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "basic error test" { + error + require compiler "category.+undefined" + require compiler "type.+undefined" + exclude stderr "." + exclude stdout "." +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + ~ undefined() + } +} + + +testcase "basic crash test" { + crash Test$execute() + require stderr "/testcase:" + require stderr "failure message!!!" + exclude stdout "failure message!!!" +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + // NOTE: "!!!" is important here because it also tests mixing of escaped and + // unescaped characters when handling string literals. + fail("failure message!!!") + } +} + + +testcase "basic success test" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { } +} + + +testcase "minimal linking works properly" { + success empty +} diff --git a/tests/typename.0rt b/tests/typename.0rt new file mode 100644 --- /dev/null +++ b/tests/typename.0rt @@ -0,0 +1,271 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "String typename" { + success Test$run() +} + +define Test { + run () { + Formatted name <- typename() + if (name.formatted() != "String") { + fail(name) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Int typename" { + success Test$run() +} + +define Test { + run () { + Formatted name <- typename() + if (name.formatted() != "Int") { + fail(name) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Char typename" { + success Test$run() +} + +define Test { + run () { + Formatted name <- typename() + if (name.formatted() != "Char") { + fail(name) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Float typename" { + success Test$run() +} + +define Test { + run () { + Formatted name <- typename() + if (name.formatted() != "Float") { + fail(name) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Bool typename" { + success Test$run() +} + +define Test { + run () { + Formatted name <- typename() + if (name.formatted() != "Bool") { + fail(name) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Formatted typename" { + success Test$run() +} + +define Test { + run () { + Formatted name <- typename() + if (name.formatted() != "Formatted") { + fail(name) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "ReadPosition typename" { + success Test$run() +} + +define Test { + run () { + Formatted name <- typename>() + if (name.formatted() != "ReadPosition") { + fail(name) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "any typename" { + success Test$run() +} + +define Test { + run () { + Formatted name <- typename() + if (name.formatted() != "any") { + fail(name) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "all typename" { + success Test$run() +} + +define Test { + run () { + Formatted name <- typename() + if (name.formatted() != "all") { + fail(name) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "intersect typename" { + success Test$run() +} + +define Test { + run () { + Formatted name <- typename<[String&Int]>() + if (name.formatted() != "[String&Int]") { + fail(name) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "union typename" { + success Test$run() +} + +define Test { + run () { + Formatted name <- typename<[String|Int]>() + if (name.formatted() != "[String|Int]") { + fail(name) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "param typename" { + success Test$run() +} + +@value interface Value<#x> {} + +@value interface Type<#x,#y> {} + +define Test { + @category getTypename<#x,#y> () -> (Formatted) + getTypename () { + return typename>() + } + + run () { + Formatted name <- getTypename>() + if (name.formatted() != "Type>") { + fail(name) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "bad instance in typename param" { + error + require "Test" + require "define" + require "Equals" +} + +@value interface Value<#x> { + #x defines Equals<#x> +} + +concrete Call { + @type call<#x> () -> () +} + +define Call { + call () {} +} + +define Test { + run () { + ~ typename>() + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/unary-functions.0rt b/tests/unary-functions.0rt new file mode 100644 --- /dev/null +++ b/tests/unary-functions.0rt @@ -0,0 +1,146 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "category unary" { + success Test$run() +} + +define Test { + @category neg (Int) -> (Int) + neg (x) { + return -x + } + + run () { + Int value <- `Test$$neg` 2 + if (value != -2) { + fail(value) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "type unary" { + success Test$run() +} + +define Test { + @type neg (Int) -> (Int) + neg (x) { + return -x + } + + run () { + Int value <- `Test$neg` 2 + if (value != -2) { + fail(value) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "value unary" { + success Test$run() +} + +concrete Arithmetic { + @type create () -> (Arithmetic) + @value neg (Int) -> (Int) +} + +define Arithmetic { + create () { + return Arithmetic{ } + } + + neg (x) { + return -x + } +} + +define Test { + run () { + Int value <- `Arithmetic$create().neg` 2 + if (value != -2) { + fail(value) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "unqualified unary" { + success Test$run() +} + +define Test { + @type neg (Int) -> (Int) + neg (x) { + return -x + } + + run () { + Int value <- `neg` 2 + if (value != -2) { + fail(value) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "unary function with infix function" { + success Test$run() +} + +define Test { + @category add (Int,Int) -> (Int) + add (x,y) { + return x + y + } + + @type neg (Int) -> (Int) + neg (x) { + return -x + } + + run () { + Int value <- 1 `add` `neg` 2 + if (value != -1) { + fail(value) + } + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/unreachable.0rt b/tests/unreachable.0rt new file mode 100644 --- /dev/null +++ b/tests/unreachable.0rt @@ -0,0 +1,141 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "warning statement after fail" { + success Test$run() + require compiler "unreachable" +} + +define Test { + @category failedReturn () -> (Int) + failedReturn () { + fail("Failed") + return 1 + } + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "warning statement after return" { + success Test$run() + require compiler "unreachable" +} + +define Test { + @category failedReturn () -> (Int) + failedReturn () { + return 0 + return 1 + } + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "warning statement after conditional return" { + success Test$run() + require compiler "unreachable" +} + +define Test { + @category failedReturn () -> (Int) + failedReturn () { + if (true) { + return 1 + } else { + return 2 + } + return 3 + } + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "warning statement after scoped return" { + success Test$run() + require compiler "unreachable" +} + +define Test { + @category failedReturn () -> (Int) + failedReturn () { + scoped { + return 1 + } in return 2 + } + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "warning statement after cleanup return" { + success Test$run() + require compiler "unreachable" +} + +define Test { + @category failedReturn () -> (Int) + failedReturn () { + scoped { + } cleanup { + return 1 + } in ~ empty + return 2 + } + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "warning statement in cleanup after scoped return" { + success Test$run() + require compiler "unreachable" +} + +define Test { + @category failedReturn () -> (Int) + failedReturn () { + scoped { + return 1 + } cleanup { + return 2 + } in ~ empty + } + run () {} +} + +concrete Test { + @type run () -> () +} diff --git a/tests/value-init.0rt b/tests/value-init.0rt new file mode 100644 --- /dev/null +++ b/tests/value-init.0rt @@ -0,0 +1,191 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "value init in @category member" { + success Test$run() +} + +define Test { + @value Int value + @category Test singleton <- Test{ 3 } + + @value get () -> (Int) + get () { + return value + } + + run () { + if (singleton.get() != 3) { + fail(singleton.get()) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "init value same type from @type" { + success Test$run() +} + +concrete Value<#x> { + @type create (#x) -> (Value<#x>) + @value get () -> (#x) +} + +define Value { + @value #x value + + create (val) { + return Value<#x>{ val } + } + + get () { + return value + } +} + +define Test { + run () { + Value value <- Value$create(1) + if (value.get() != 1) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "init value different type from @type" { + success Test$run() +} + +concrete Value<#x> { + @type create<#y> (#y) -> (Value<#y>) + @value get () -> (#x) +} + +define Value { + @value #x value + + create (val) { + return Value<#y>{ val } + } + + get () { + return value + } +} + +define Test { + run () { + Value value <- Value$create(1) + if (value.get() != 1) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "init value same type from @value" { + success Test$run() +} + +concrete Value<#x> { + @type create (#x) -> (Value<#x>) + @value create2 (#x) -> (Value<#x>) + @value get () -> (#x) +} + +define Value { + @value #x value + + create (val) { + return Value<#x>{ val } + } + + create2 (val) { + return Value<#x>{ val } + } + + get () { + return value + } +} + +define Test { + run () { + Value value <- Value$create(2).create2(1) + if (value.get() != 1) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "init value different type from @value" { + success Test$run() +} + +concrete Value<#x> { + @type create (#x) -> (Value<#x>) + @value create2<#y> (#y) -> (Value<#y>) + @value get () -> (#x) +} + +define Value { + @value #x value + + create (val) { + return Value<#x>{ val } + } + + create2 (val) { + return Value<#y>{ val } + } + + get () { + return value + } +} + +define Test { + run () { + Value value <- Value$create("x").create2(1) + if (value.get() != 1) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/visibility.0rt b/tests/visibility.0rt new file mode 100644 --- /dev/null +++ b/tests/visibility.0rt @@ -0,0 +1,60 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "public types in private deps stay hidden" { + success Test$run() +} + +// Internal is defined in visibility/internal and visibility2/internal. The +// three definitions should not interfere with each other, despite two of them +// being public. +concrete Internal { + @type create () -> (Internal) + @value get () -> (String) +} + +define Internal { + create () { + return Internal{ } + } + + get () { + return "message" + } +} + +define Test { + run () { + String value1 <- Internal$create().get() + if (value1 != "message") { + fail(value1) + } + Int value2 <- Getter$getValue() + if (value2 != 1) { + fail(value2) + } + Int value3 <- Getter2$getValue() + if (value3 != 2) { + fail(value3) + } + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/visibility/.zeolite-module b/tests/visibility/.zeolite-module new file mode 100644 --- /dev/null +++ b/tests/visibility/.zeolite-module @@ -0,0 +1,1 @@ +RecompileMetadata {rmRoot = "..", rmPath = "visibility", rmPublicDeps = [], rmPrivateDeps = ["internal"], rmExtraFiles = [], rmExtraPaths = [], rmExtraRequires = [], rmMode = CompileIncremental, rmOutputName = ""} diff --git a/tests/visibility/getter.0rp b/tests/visibility/getter.0rp new file mode 100644 --- /dev/null +++ b/tests/visibility/getter.0rp @@ -0,0 +1,3 @@ +concrete Getter { + @type getValue () -> (Int) +} diff --git a/tests/visibility/getter.0rx b/tests/visibility/getter.0rx new file mode 100644 --- /dev/null +++ b/tests/visibility/getter.0rx @@ -0,0 +1,5 @@ +define Getter { + getValue () { + return Internal$create().get() + } +} diff --git a/tests/visibility/internal/.zeolite-module b/tests/visibility/internal/.zeolite-module new file mode 100644 --- /dev/null +++ b/tests/visibility/internal/.zeolite-module @@ -0,0 +1,1 @@ +RecompileMetadata {rmRoot = "../..", rmPath = "visibility/internal", rmPublicDeps = [], rmPrivateDeps = [], rmExtraFiles = [], rmExtraPaths = [], rmExtraRequires = [], rmMode = CompileIncremental, rmOutputName = ""} diff --git a/tests/visibility/internal/internal.0rp b/tests/visibility/internal/internal.0rp new file mode 100644 --- /dev/null +++ b/tests/visibility/internal/internal.0rp @@ -0,0 +1,4 @@ +concrete Internal { + @type create () -> (Internal) + @value get () -> (Int) +} diff --git a/tests/visibility/internal/internal.0rx b/tests/visibility/internal/internal.0rx new file mode 100644 --- /dev/null +++ b/tests/visibility/internal/internal.0rx @@ -0,0 +1,9 @@ +define Internal { + create () { + return Internal{ } + } + + get () { + return 1 + } +} diff --git a/tests/visibility2/.zeolite-module b/tests/visibility2/.zeolite-module new file mode 100644 --- /dev/null +++ b/tests/visibility2/.zeolite-module @@ -0,0 +1,1 @@ +RecompileMetadata {rmRoot = "..", rmPath = "visibility2", rmPublicDeps = [], rmPrivateDeps = ["internal"], rmExtraFiles = [], rmExtraPaths = [], rmExtraRequires = [], rmMode = CompileIncremental, rmOutputName = ""} diff --git a/tests/visibility2/getter2.0rp b/tests/visibility2/getter2.0rp new file mode 100644 --- /dev/null +++ b/tests/visibility2/getter2.0rp @@ -0,0 +1,3 @@ +concrete Getter2 { + @type getValue () -> (Int) +} diff --git a/tests/visibility2/getter2.0rx b/tests/visibility2/getter2.0rx new file mode 100644 --- /dev/null +++ b/tests/visibility2/getter2.0rx @@ -0,0 +1,5 @@ +define Getter2 { + getValue () { + return Internal$create().get() + } +} diff --git a/tests/visibility2/internal/.zeolite-module b/tests/visibility2/internal/.zeolite-module new file mode 100644 --- /dev/null +++ b/tests/visibility2/internal/.zeolite-module @@ -0,0 +1,1 @@ +RecompileMetadata {rmRoot = "../..", rmPath = "visibility2/internal", rmPublicDeps = [], rmPrivateDeps = [], rmExtraFiles = [], rmExtraPaths = [], rmExtraRequires = [], rmMode = CompileIncremental, rmOutputName = ""} diff --git a/tests/visibility2/internal/internal.0rp b/tests/visibility2/internal/internal.0rp new file mode 100644 --- /dev/null +++ b/tests/visibility2/internal/internal.0rp @@ -0,0 +1,4 @@ +concrete Internal { + @type create () -> (Internal) + @value get () -> (Int) +} diff --git a/tests/visibility2/internal/internal.0rx b/tests/visibility2/internal/internal.0rx new file mode 100644 --- /dev/null +++ b/tests/visibility2/internal/internal.0rx @@ -0,0 +1,9 @@ +define Internal { + create () { + return Internal{ } + } + + get () { + return 2 + } +} diff --git a/tests/while.0rt b/tests/while.0rt new file mode 100644 --- /dev/null +++ b/tests/while.0rt @@ -0,0 +1,449 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "assign while" { + error + require "value.+before return" +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value) + process () (value) { + while (false) { + value <- empty + } + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "assign while condition" { + error + require "value.+before return" +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value) + process () (value) { + while (present((value <- empty))) {} + } + + run () {} +} + +concrete Test { + @type run () -> () +} + +testcase "return while" { + error + require "return" +} + +@value interface Value {} + +define Test { + @value process () -> (optional Value) + process () { + while (false) { + return empty + } + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + +testcase "break outside of while" { + error + require "while" + require "break" +} + +define Test { + run () { + break + } +} + +concrete Test { + @type run () -> () +} + + +testcase "continue outside of while" { + error + require "while" + require "continue" +} + +define Test { + run () { + continue + } +} + +concrete Test { + @type run () -> () +} + + +testcase "while with break" { + success Test$run() +} + +define Test { + run () { + Int output <- -1 + scoped { + Int i <- 0 + Int limit <- 5 + } in while (i < limit) { + output <- i + break + fail("Failed") + } + if (output != 0) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "while with update" { + success Test$run() +} + +define Test { + run () { + Int output <- -1 + scoped { + Int i <- 0 + Int limit <- 5 + } in while (i < limit) { + output <- i + } update { + i <- i+1 + } + if (output != 4) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "break in update" { + success Test$run() +} + +define Test { + run () { + Int output <- 0 + while (true) { + } update { + if (output > 5) { + break + fail("Failed") + } + output <- output+1 + } + if (output != 6) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "return in update" { + success Test$run() +} + +define Test { + @type test () -> (Int) + test () { + Int output <- 0 + while ((output <- output+1) > 0) { + } update { + if (output > 5) { + return output + fail("Failed") + } + } + return -1 + } + + run () { + if (test() != 6) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "break and continue in if/else" { + success Test$run() +} + +define Test { + run () { + Int i <- 0 + while (true) { + if (i > 5) { + break + } else { + continue + } + fail("Failed") + } update { + i <- i+1 + } + if (i != 6) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "update clashes with while" { + success Test$run() +} + +define Test { + run () { + while (false) { + Int x <- 2 + } update { + Int x <- 1 + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "while without update" { + success Test$run() +} + +define Test { + run () { + Int output <- -1 + scoped { + Int i <- 0 + Int limit <- 5 + } in while (i < limit) { + output <- i + i <- i+1 + } + if (output != 4) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "while with continue and update" { + success Test$run() +} + +define Test { + run () { + Int output <- -1 + scoped { + Int i <- 0 + Int limit <- 5 + } in while (i < limit) { + output <- i + continue + fail("Failed") + } update { + i <- i+1 + } + if (output != 4) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "while with continue and without update" { + success Test$run() +} + +define Test { + run () { + Int output <- -1 + scoped { + Int i <- 0 + Int limit <- 5 + } in while (i < limit) { + output <- i + i <- i+1 + continue + fail("Failed") + } + if (output != 4) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "crash in while" { + crash Test$run() + require "empty" +} + +define Test { + run () { + optional Bool test <- empty + while (require(test)) { + // empty + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "cleanup after break" { + success Test$run() +} + +define Test { + run () { + Int value <- 0 + scoped { + value <- 1 + } cleanup { + value <- 2 + } in while (true) { + value <- 3 + break + } + if (value != 2) { + fail(value) + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "cleanup before return in while" { + success Test$run() +} + +concrete Value { + @type create () -> (Value) + @value call () -> (Int) + @value get () -> (Int) +} + +define Value { + @value Int value + + create () { + return Value{ 0 } + } + + call () { + value <- 1 + scoped { + value <- 2 + } cleanup { + value <- 3 + } in while (true) { + return value + } + return 4 + } + + get () { + return value + } +} + +define Test { + run () { + Value value <- Value$create() + Int value1 <- value.call() + if (value1 != 2) { + fail(value1) + } + Int value2 <- value.get() + if (value2 != 3) { + fail(value2) + } + } +} + +concrete Test { + @type run () -> () +} diff --git a/zeolite-lang.cabal b/zeolite-lang.cabal new file mode 100644 --- /dev/null +++ b/zeolite-lang.cabal @@ -0,0 +1,215 @@ +name: zeolite-lang +version: 0.1.0.0 +synopsis: Zeolite is a statically-typed, general-purpose programming language. + +description: + Zeolite is an experimental general-purpose programming language. See + for more details. + . + The installation process is still a bit rough, and therefore must be done in a + few stages: + . + * Ensure that you have a C++ compiler such as @clang++@ or @g++@ installed, + and an archiver such as @ar@ installed, all callable from a shell. + * Install the binaries using @cabal@. After this step, the compiler itself is + installed, but it cannot actually create executables from source code. + . + @ + cabal install zeolite-lang + @ + . + * Execute the setup binary that gets installed by @cabal@. This will give you + a series of prompts to verify the binaries above. It will then + automatically build the supporting libraries. + . + @ + zeolite-setup + @ + . + * (Optional) Once the setup above is completed, you should run the + integration tests to ensure that code can be compiled and run. These can + take quite a while to complete. Please create an + if you encounter + any errors. + . + @ + ZEOLITE_PATH=$(zeolite --get-path) + zeolite -p "$ZEOLITE_PATH" -t tests lib\/file lib\/util + @ + . + The are + located in @$ZEOLITE_PATH/example@. You should not normally need to use + @$ZEOLITE_PATH@ outside of running included tests and examples. + +homepage: https://github.com/ta0kira/zeolite +license: Apache-2.0 +license-file: LICENSE +author: Kevin P. Barry +maintainer: Kevin P. Barry +copyright: (c) Kevin P. Barry 2019-2020 +category: Compiler +build-type: Simple + +cabal-version: 2.0 +tested-with: GHC == 8.8.3 + +extra-source-files: ChangeLog.md +extra-source-files: src/Test/testfiles/*.0rt, + src/Test/testfiles/*.0rx + +data-files: base/.zeolite-module, + base/*.0rp, + base/*.cpp, + base/*.hpp, + base/.zeolite-module, + base/*.0rp, + base/*.cpp, + capture-thread/include/*.h, + capture-thread/src/*.cc, + example/hello/README.md, + example/hello/*.0rx, + example/regex/README.md, + example/regex/*.0rp, + example/regex/*.0rt, + example/regex/*.0rx, + example/tree/README.md, + example/tree/*.0rp, + example/tree/*.0rt, + example/tree/*.0rx, + lib/file/.zeolite-module, + lib/file/*.0rp, + lib/file/*.0rt, + lib/file/*.cpp, + lib/util/.zeolite-module, + lib/util/*.0rp, + lib/util/*.0rt, + lib/util/*.0rx, + lib/util/*.cpp, + tests/.zeolite-module, + tests/*.0rt, + tests/multiple-defs/README.md, + tests/multiple-defs/.zeolite-module, + tests/multiple-defs/*.0rp, + tests/multiple-defs/*.0rx, + tests/visibility/.zeolite-module, + tests/visibility/*.0rp, + tests/visibility/*.0rx, + tests/visibility/internal/.zeolite-module, + tests/visibility/internal/*.0rp, + tests/visibility/internal/*.0rx, + tests/visibility2/.zeolite-module, + tests/visibility2/*.0rp, + tests/visibility2/*.0rx, + tests/visibility2/internal/.zeolite-module, + tests/visibility2/internal/*.0rp, + tests/visibility2/internal/*.0rx + + +library zeolite-internal + exposed-modules: Base.CompileError, + Base.Mergeable, + Cli.CompileMetadata, + Cli.CompileOptions, + Cli.Compiler, + Cli.ParseCompileOptions, + Cli.TestRunner, + Compilation.CompileInfo, + Compilation.CompilerState, + Compilation.ProcedureContext, + Compilation.ScopeContext, + CompilerCxx.Category, + CompilerCxx.CategoryContext, + CompilerCxx.Code, + CompilerCxx.Naming, + CompilerCxx.Procedure, + Config.LoadConfig, + Config.Paths, + Config.Programs, + Parser.Common, + Parser.DefinedCategory, + Parser.IntegrationTest, + Parser.Procedure, + Parser.SourceFile, + Parser.TypeCategory, + Parser.TypeInstance, + Test.Common, + Test.DefinedCategory, + Test.IntegrationTest, + Test.Parser, + Test.Procedure, + Test.TypeCategory, + Test.TypeInstance, + Types.Builtin, + Types.DefinedCategory, + Types.Function, + Types.GeneralType, + Types.IntegrationTest, + Types.Positional, + Types.Procedure, + Types.TypeCategory, + Types.TypeInstance, + Types.Variance + + other-modules: Paths_zeolite_lang + + autogen-modules: Paths_zeolite_lang + + other-extensions: CPP, + ExistentialQuantification, + FlexibleContexts, + FlexibleInstances, + FunctionalDependencies, + MultiParamTypeClasses, + Safe, + ScopedTypeVariables + + build-depends: base >= 4.2 && < 4.14, + containers >= 0.3 && < 0.7, + directory >= 1.1 && < 1.4, + filepath >= 1.0 && < 1.5, + hashable >= 1.0 && < 1.4, + mtl >= 1.0 && < 2.3, + parsec >= 3.0 && < 3.2, + regex-tdfa >= 1.0 && < 1.4, + transformers >= 0.1 && < 0.6, + unix >= 2.0 && <= 2.8 + + hs-source-dirs: src + default-language: Haskell2010 + + +executable zeolite + main-is: bin/zeolite.hs + + build-depends: base, + containers, + directory, + filepath, + unix, + zeolite-internal + + default-language: Haskell2010 + + +executable zeolite-setup + main-is: bin/zeolite-setup.hs + + build-depends: base, + directory, + filepath, + zeolite-internal + + default-language: Haskell2010 + + +test-suite zeolite-test + type: exitcode-stdio-1.0 + + main-is: bin/unit-tests.hs + + build-depends: base, + directory, + filepath, + zeolite-internal + + default-language: Haskell2010