packages feed

zeolite-lang (empty) → 0.1.0.0

raw patch · 235 files changed

+28424/−0 lines, 235 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, filepath, hashable, mtl, parsec, regex-tdfa, transformers, unix, zeolite-lang

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for zeolite++## 0.1.0.0  -- 2020-04-27++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ base/.zeolite-module view
@@ -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 = ""}
+ base/argv.cpp view
@@ -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<std::string>& ProgramArgv::GetArgs() const {+  return argv_;+}
+ base/argv.hpp view
@@ -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 <string>+#include <vector>++#include "thread-capture.h"+++class Argv : public capture_thread::ThreadCapture<Argv> {+ public:+  static int ArgCount();+  static const std::string& GetArgAt(int pos);++ protected:+  virtual ~Argv() = default;++ private:+  virtual const std::vector<std::string>& 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<std::string>& GetArgs() const final;++  const std::vector<std::string> argv_;+  const ScopedCapture capture_to_;+};++#endif  // ARGV_HPP_
+ base/builtin.0rp view
@@ -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<Bool>+}++concrete Char {+  refines AsBool+  refines AsChar+  refines AsInt+  refines AsFloat+  refines Formatted++  defines Equals<Char>+  defines LessThan<Char>+}++concrete Int {+  refines AsBool+  refines AsChar+  refines AsInt+  refines AsFloat+  refines Formatted++  defines Equals<Int>+  defines LessThan<Int>+}++concrete Float {+  refines AsBool+  refines AsInt+  refines AsFloat+  refines Formatted++  defines Equals<Float>+  defines LessThan<Float>+}++concrete String {+  refines AsBool+  refines Formatted+  refines ReadPosition<Char>++  defines Equals<String>+  defines LessThan<String>++  @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>)+}
+ base/builtin.cpp view
@@ -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 <map>+#include <sstream>++#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<TypeValue>& formatted) {+  FAIL() << TypeValue::Call(formatted, Function_Formatted_formatted,+                            ParamTuple(), ArgTuple()).Only()->AsString();+  __builtin_unreachable();+}++namespace {++struct OptionalEmpty : public TypeValue {+  ReturnTuple Dispatch(const S<TypeValue>& 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<TypeInstance*> 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<const TypeInstance*> MergedTypes() const final+  { return params_; }++  const L<const TypeInstance*> params_;+};++struct Type_Union : public TypeInstance {+  Type_Union(L<TypeInstance*> 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<const TypeInstance*> MergedTypes() const final+  { return params_; }++  const L<const TypeInstance*> params_;+};++}  // namespace+++TypeInstance& Merge_Intersect(L<TypeInstance*> params) {+  static auto& cache = *new std::map<L<TypeInstance*>,R<Type_Intersect>>();+  auto& cached = cache[params];+  if (!cached) { cached = R_get(new Type_Intersect(params)); }+  return *cached;+}++TypeInstance& Merge_Union(L<TypeInstance*> params) {+  static auto& cache = *new std::map<L<TypeInstance*>,R<Type_Union>>();+  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<TypeInstance*>());+  return instance;+}++TypeInstance& GetMerged_All() {+  static auto& instance = Merge_Union(L_get<TypeInstance*>());+  return instance;+}+++const S<TypeValue>& Var_empty = *new S<TypeValue>(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<TypeValue> 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<Category_Bool>::Check();+    CycleCheck<Category_Bool> 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<const TypeInstance*> 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<const TypeInstance*>& args) const final {+    if (&category == &GetCategory_Bool()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_AsBool()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_AsInt()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_AsFloat()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_Formatted()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    return false;+  }+  Type_Bool(Category_Bool& p, Params<0>::Type params) : parent(p) {+    CycleCheck<Type_Bool>::Check();+    CycleCheck<Type_Bool> 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<TypeValue>& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final {+    using CallType = ReturnTuple(Value_Bool::*)(const S<TypeValue>&, 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<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_asFloat(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_asInt(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_formatted(const S<TypeValue>& 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<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args) {+  TRACE_FUNCTION("Bool.asBool")+  return ReturnTuple(Var_self);+}+ReturnTuple Value_Bool::Call_asFloat(const S<TypeValue>& 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<TypeValue>& 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<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args) {+  TRACE_FUNCTION("Bool.formatted")+  return ReturnTuple(Box_String(value_? "true" : "false"));+}+const S<TypeValue>& Var_true = *new S<TypeValue>(new Value_Bool(CreateType_Bool(Params<0>::Type()), true));+const S<TypeValue>& Var_false = *new S<TypeValue>(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<TypeValue> 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<Category_Char>::Check();+    CycleCheck<Category_Char> 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<const TypeInstance*> 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<const TypeInstance*>& args) const final {+    if (&category == &GetCategory_Char()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_AsBool()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_AsChar()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_AsInt()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_AsFloat()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_Formatted()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    return false;+  }+  Type_Char(Category_Char& p, Params<0>::Type params) : parent(p) {+    CycleCheck<Type_Char>::Check();+    CycleCheck<Type_Char> 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<TypeValue>& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final {+    using CallType = ReturnTuple(Value_Char::*)(const S<TypeValue>&, 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<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_asChar(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_asFloat(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_asInt(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_formatted(const S<TypeValue>& 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_arg2));+}+ReturnTuple Value_Char::Call_asBool(const S<TypeValue>& 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<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args) {+  TRACE_FUNCTION("Char.asChar")+  return ReturnTuple(Var_self);+}+ReturnTuple Value_Char::Call_asFloat(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args) {+  TRACE_FUNCTION("Char.asFloat")+  return ReturnTuple(Box_Float(value_));+}+ReturnTuple Value_Char::Call_asInt(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args) {+  TRACE_FUNCTION("Char.asInt")+  return ReturnTuple(Box_Int(value_));+}+ReturnTuple Value_Char::Call_formatted(const S<TypeValue>& 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<TypeValue> 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<Category_Int>::Check();+    CycleCheck<Category_Int> 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<const TypeInstance*> 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<const TypeInstance*>& args) const final {+    if (&category == &GetCategory_Int()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_AsBool()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_AsChar()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_AsInt()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_AsFloat()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_Formatted()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    return false;+  }+  Type_Int(Category_Int& p, Params<0>::Type params) : parent(p) {+    CycleCheck<Type_Int>::Check();+    CycleCheck<Type_Int> 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<TypeValue>& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final {+    using CallType = ReturnTuple(Value_Int::*)(const S<TypeValue>&, 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<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_asChar(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_asFloat(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_asInt(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_formatted(const S<TypeValue>& 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_arg2));+}+ReturnTuple Value_Int::Call_asBool(const S<TypeValue>& 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<TypeValue>& 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<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args) {+  TRACE_FUNCTION("Int.asFloat")+  return ReturnTuple(Box_Float(value_));+}+ReturnTuple Value_Int::Call_asInt(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args) {+  TRACE_FUNCTION("Int.asInt")+  return ReturnTuple(Var_self);+}+ReturnTuple Value_Int::Call_formatted(const S<TypeValue>& 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<TypeValue> 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<Category_Float>::Check();+    CycleCheck<Category_Float> 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<const TypeInstance*> 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<const TypeInstance*>& args) const final {+    if (&category == &GetCategory_Float()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_AsBool()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_AsInt()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_AsFloat()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_Formatted()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    return false;+  }+  Type_Float(Category_Float& p, Params<0>::Type params) : parent(p) {+    CycleCheck<Type_Float>::Check();+    CycleCheck<Type_Float> 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<TypeValue>& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final {+    using CallType = ReturnTuple(Value_Float::*)(const S<TypeValue>&, 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<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_asFloat(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_asInt(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_formatted(const S<TypeValue>& 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_arg2));+}+ReturnTuple Value_Float::Call_asBool(const S<TypeValue>& 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<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args) {+  TRACE_FUNCTION("Float.asFloat")+  return ReturnTuple(Var_self);+}+ReturnTuple Value_Float::Call_asInt(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args) {+  TRACE_FUNCTION("Float.asInt")+  return ReturnTuple(Box_Int(value_));+}+ReturnTuple Value_Float::Call_formatted(const S<TypeValue>& 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<TypeValue> 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<Category_String>::Check();+    CycleCheck<Category_String> 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<const TypeInstance*> 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<const TypeInstance*>& args) const final {+    if (&category == &GetCategory_String()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_AsBool()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_Formatted()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_ReadPosition()) {+      args = std::vector<const TypeInstance*>{&GetType_Char(T_get())};+      return true;+    }+    return false;+  }+  Type_String(Category_String& p, Params<0>::Type params) : parent(p) {+    CycleCheck<Type_String>::Check();+    CycleCheck<Type_String> 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<TypeValue>& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final {+    using CallType = ReturnTuple(Value_String::*)(const S<TypeValue>&, 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<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_formatted(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_readPosition(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_readSize(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_subSequence(const S<TypeValue>& 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<TypeValue>& Var_arg1 = (args.At(0));+  const S<TypeValue>& 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<TypeValue>& Var_arg1 = (args.At(0));+  const S<TypeValue>& Var_arg2 = (args.At(1));+  return ReturnTuple(Box_Bool(Var_arg1->AsString()<Var_arg2->AsString()));+}+ReturnTuple Value_String::Call_asBool(const S<TypeValue>& 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<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args) {+  TRACE_FUNCTION("String.formatted")+  return ReturnTuple(Var_self);+}+ReturnTuple Value_String::Call_readPosition(const S<TypeValue>& 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<TypeValue>& 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<TypeValue>& 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<TypeValue> Box_Bool(bool value) {+  return value? Var_true : Var_false;+}++S<TypeValue> Box_Char(PrimChar value) {+  return S_get(new Value_Char(CreateType_Char(Params<0>::Type()), value));+}++S<TypeValue> Box_Int(PrimInt value) {+  return S_get(new Value_Int(CreateType_Int(Params<0>::Type()), value));+}++S<TypeValue> Box_Float(PrimFloat value) {+  return S_get(new Value_Float(CreateType_Float(Params<0>::Type()), value));+}++S<TypeValue> Box_String(const PrimString& value) {+  return S_get(new Value_String(CreateType_String(Params<0>::Type()), value));+}
+ base/builtin.hpp view
@@ -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<TypeValue>& formatted) __attribute__ ((noreturn));++TypeInstance& Merge_Intersect(L<TypeInstance*> params);+TypeInstance& Merge_Union(L<TypeInstance*> params);++TypeInstance& GetMerged_Any();+TypeInstance& GetMerged_All();++S<TypeValue> Box_Bool(bool value);+S<TypeValue> Box_String(const PrimString& value);+S<TypeValue> Box_Char(PrimChar value);+S<TypeValue> Box_Int(PrimInt value);+S<TypeValue> Box_Float(PrimFloat value);++extern const S<TypeValue>& Var_empty;++#endif  // BUILTIN_HPP_
+ base/category-header.hpp view
@@ -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 <string>++#include "types.hpp"+++class TypeCategory;+class TypeInstance;+class TypeValue;+class CategoryFunction;+class TypeFunction;+class ValueFunction;++#endif  // CATEGORY_HEADER_HPP_
+ base/category-source.cpp view
@@ -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<TypeValue>& 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<TypeValue> target) {+  if (target == nullptr) {+    FAIL() << "Builtin called on null value";+  }+  return target->Present();+}++S<TypeValue> TypeValue::Require(S<TypeValue> target) {+  if (target == nullptr) {+    FAIL() << "Builtin called on null value";+  }+  if (!target->Present()) {+    FAIL() << "Cannot require empty value";+  }+  return target;+}++S<TypeValue> TypeValue::Strong(W<TypeValue> 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;+}
+ base/category-source.hpp view
@@ -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 <map>+#include <sstream>+#include <vector>++#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<TypeValue> Reduce(TypeInstance& from, TypeInstance& to, S<TypeValue> target) {+    TRACE_FUNCTION("reduce")+    return CanConvert(from, to)? target : Var_empty;+  }++  virtual bool TypeArgsForParent(+    const TypeCategory& category, std::vector<const TypeInstance*>& 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<class...Ts>+  static void TypeNameFrom(std::ostream& output, const TypeCategory& category,+                           const Ts&... params) {+    std::vector<const TypeInstance*> params2{&params...};+    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<const TypeInstance*> MergedTypes() const+  { return std::vector<const TypeInstance*>{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<TypeValue>& 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<TypeValue> target);+  static S<TypeValue> Require(S<TypeValue> target);+  static S<TypeValue> Strong(W<TypeValue> 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<TypeValue>& self,+                               const ValueFunction& label,+                               const ParamTuple& params, const ValueTuple& args);+};++template<int P, class T>+using InstanceMap = std::map<typename Params<P>::Type, R<T>>;++#endif  // CATEGORY_SOURCE_HPP_
+ base/cycle-check.hpp view
@@ -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 Type>+class CycleCheck : public capture_thread::ThreadCapture<CycleCheck<Type>> {+ public:+  CycleCheck(const Type& type) : type_(type), capture_to_(this) {}++  static void Check() {+    auto current = capture_thread::ThreadCapture<CycleCheck<Type>>::GetCurrent();+    if (current) {+      FAIL() << "Detected cycle in " << current->type_.CategoryName() << " init";+    }+  }++ private:+  const Type& type_;+  const typename capture_thread::ThreadCapture<CycleCheck<Type>>::ScopedCapture capture_to_;+};++#endif  // CYCLE_CHECK_HPP_
+ base/function.hpp view
@@ -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 <ostream>+++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_
+ base/logging.cpp view
@@ -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 <cassert>+#include <csignal>+#include <iostream>++#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<std::string> TraceContext::GetTrace() {+  std::list<std::string> 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<std::string>& 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<std::string>& 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();+}
+ base/logging.hpp view
@@ -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 <list>+#include <sstream>+#include <string>++#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<class T>+  LogThenCrash& operator << (const T& stuff) {+    if (fail_) {+      static_cast<std::ostream&>(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<TraceContext> {+ public:+  static std::list<std::string> GetTrace();++  template<int S>+  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<std::string>& trace) const = 0;+  virtual const TraceContext* GetNext() const = 0;+};++class SourceContext : public TraceContext {+ public:+  template<int S>+  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<std::string>& 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<std::string>& trace) const final;+  const TraceContext* GetNext() const final;++  const char* at_;+  const AutoThreadCrosser cross_and_capture_to_;+};++#endif  // LOGGING_HPP_
+ base/types.cpp view
@@ -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<TypeValue>& ArgTuple::At(int pos) const {+  if (pos < 0 || pos >= args_.size()) {+    FAIL() << "Bad ArgTuple index";+  }+  return *args_[pos];+}++const S<TypeValue>& ArgTuple::Only() const {+  if (args_.size() != 1) {+    FAIL() << "Bad ArgTuple index";+  }+  return *args_[0];+}++int ReturnTuple::Size() const {+  return returns_.size();+}++S<TypeValue>& ReturnTuple::At(int pos) {+  if (pos < 0 || pos >= returns_.size()) {+    FAIL() << "Bad ReturnTuple index";+  }+  return returns_[pos];+}++const S<TypeValue>& ReturnTuple::At(int pos) const {+  if (pos < 0 || pos >= returns_.size()) {+    FAIL() << "Bad ReturnTuple index";+  }+  return returns_[pos];+}++const S<TypeValue>& 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];+}
+ base/types.hpp view
@@ -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 <cstdint>+#include <functional>+#include <memory>+#include <tuple>+#include <vector>++#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<int S>+inline PrimString PrimString_FromLiteral(const char(&literal)[S]) {+  return PrimString(literal, literal + (S - 1));+}++template<class T>+using R = std::unique_ptr<T>;++template<class T>+inline R<T> R_get(T* val) { return R<T>(val); }++template<class T>+using S = std::shared_ptr<T>;++template<class T>+inline S<T> S_get(T* val) { return S<T>(val); }++template<class T>+using W = std::weak_ptr<T>;++template<class T>+inline W<T> W_get(T* val) { return W<T>(val); }++template<class...Ts>+using T = std::tuple<Ts...>;++template<class...Ts>+T<Ts...> T_get(Ts... ts) { return std::make_tuple(ts...); }++template<class T>+using L = std::vector<T>;++template<class T, class...Ts>+inline L<T> L_get(Ts... ts) { return L<T>{ts...}; }++template<class T>+class LazyInit {+ public:+  LazyInit(const std::function<T()>& 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<T()> create_;+};+++class TypeCategory;+class TypeInstance;+class TypeValue;++template<int N, class...Ts>+struct Params {+  using Type = typename Params<N-1, TypeInstance*, Ts...>::Type;+};++template<class...Ts>+struct Params<0, Ts...> {+  using Type = T<Ts...>;+};+++class ValueTuple {+ public:+  virtual int Size() const = 0;+  virtual const S<TypeValue>& At(int pos) const = 0;+  virtual const S<TypeValue>& 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<class...Ts>+  explicit ReturnTuple(Ts... returns) : returns_{std::move(returns)...} {}++  int Size() const final;+  S<TypeValue>& At(int pos);+  const S<TypeValue>& At(int pos) const final;+  const S<TypeValue>& Only() const final;++ private:+  ReturnTuple(const ReturnTuple&) = delete;+  ReturnTuple& operator =(const ReturnTuple&) = delete;++  std::vector<S<TypeValue>> returns_;+};++class ArgTuple : public ValueTuple {+ public:+  template<class...Ts>+  explicit ArgTuple(const Ts&... args) : args_{&args...} {}++  int Size() const final;+  const S<TypeValue>& At(int pos) const final;+  const S<TypeValue>& Only() const final;++ private:+  ArgTuple(const ArgTuple&) = delete;+  ArgTuple& operator =(const ArgTuple&) = delete;++  std::vector<const S<TypeValue>*> args_;+};++class ParamTuple {+ public:+  ParamTuple(ParamTuple&& other) : params_(std::move(other.params_)) {}++  template<class...Ts>+  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<TypeInstance*> params_;+};++#endif  // TYPES_HPP_
+ bin/unit-tests.hs view
@@ -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)
+ bin/zeolite-setup.hs view
@@ -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
+ bin/zeolite.hs view
@@ -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."
+ capture-thread/include/thread-capture.h view
@@ -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 <cassert>++#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<Type> 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 Type>+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<Type>::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<Type>::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<void()>& call,+                        const ReverseScope& reverse_scope) const final;++    void ReconstructContextAndCall(+        const std::function<void()>& 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 <class Type>+thread_local Type* ThreadCapture<Type>::current_(nullptr);++template <class Type>+void ThreadCapture<Type>::AutoThreadCrosser::FindTopAndCall(+    const std::function<void()>& 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 <class Type>+void ThreadCapture<Type>::AutoThreadCrosser::ReconstructContextAndCall(+    const std::function<void()>& 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_
+ capture-thread/include/thread-crosser.h view
@@ -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 <functional>+#include <type_traits>++#include <cassert>++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<void()> WrapCall(std::function<void()> 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 <class Return, class... Args>+  static inline std::function<Return(Args...)> WrapFunction(+      Return (*function)(Args...)) {+    return WrapFunction(std::function<Return(Args...)>(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 <class Return, class... Args>+  static std::function<Return(Args...)> WrapFunction(+      std::function<Return(Args...)> 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<void()>& 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<void()>& 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<void()>& 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 <class Type>+  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 <class Return, class... Args>+  struct AutoCall;++  static ThreadCrosser* GetCurrent();+  static void SetCurrent(ThreadCrosser* value);++  template <class Type>+  friend class ThreadCapture;+};++template <class Return, class... Args>+std::function<Return(Args...)> ThreadCrosser::WrapFunction(+    std::function<Return(Args...)> function) {+  const auto current = GetCurrent();+  if (function && current) {+    return [current, function](Args... args) -> Return {+      return AutoCall<Return, Args...>::Execute(*current, function,+                                                AutoMove<Args>::Pass(args)...);+    };+  } else {+    return function;+  }+}++// Handles pass-by-value.+template <class Type>+struct ThreadCrosser::AutoMove {+  static Type&& Pass(Type& value) { return std::move(value); }+};++// Handles pass-by-reference.+template <class Type>+struct ThreadCrosser::AutoMove<Type&> {+  static Type& Pass(Type& value) { return value; }+};++// Handles return-by-value.+template <class Return, class... Args>+struct ThreadCrosser::AutoCall {+  static Return Execute(const ThreadCrosser& current,+                        const std::function<Return(Args...)>& function,+                        Args... args) {+    typename std::remove_cv<Return>::type value = Return();+    current.CallInFullContext([&value, &function, &args...] {+      value = function(AutoMove<Args>::Pass(args)...);+    });+    return value;+  }+};++// Handles return-by-reference.+template <class Return, class... Args>+struct ThreadCrosser::AutoCall<Return&, Args...> {+  static Return& Execute(const ThreadCrosser& current,+                         const std::function<Return&(Args...)>& function,+                         Args... args) {+    Return* value(nullptr);+    current.CallInFullContext([&value, &function, &args...] {+      value = &function(AutoMove<Args>::Pass(args)...);+    });+    assert(value);+    return *value;+  }+};++// Handles void return type.+template <class... Args>+struct ThreadCrosser::AutoCall<void, Args...> {+  static void Execute(const ThreadCrosser& current,+                      const std::function<void(Args...)>& function,+                      Args... args) {+    current.CallInFullContext(+        [&function, &args...] { function(AutoMove<Args>::Pass(args)...); });+  }+};++// Handles callback type.+template <>+struct ThreadCrosser::AutoCall<void> {+  static void Execute(const ThreadCrosser& current,+                      const std::function<void()>& function) {+    current.CallInFullContext(function);+  }+};++}  // namespace capture_thread++#endif  // THREAD_CROSSER_H_
+ capture-thread/src/thread-crosser.cc view
@@ -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
+ example/hello/README.md view
@@ -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+```
+ example/hello/hello-demo.0rx view
@@ -0,0 +1,28 @@+concrete HelloDemo {+  @type run () -> ()+}++define HelloDemo {+  run () {+    scoped {+      TextReader reader <- TextReader$fromBlockReader(SimpleInput$stdin())+    } cleanup {+      ~ LazyStream<Formatted>$new()+          .append("Goodbye.\n")+          .writeTo(SimpleOutput$stderr())+    } in while (!reader.pastEnd()) {+      ~ LazyStream<Formatted>$new()+          .append("What is your name? ")+          .writeTo(SimpleOutput$stderr())+      String name <- reader.readNextLine()+      if (name.readSize() == 0) {+        break+      }+      ~ LazyStream<Formatted>$new()+          .append("Hello \"")+          .append(name)+          .append("\", if that's your real name.\n")+          .writeTo(SimpleOutput$stderr())+    }+  }+}
+ example/regex/README.md view
@@ -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+```
+ example/regex/char-regex.0rp view
@@ -0,0 +1,4 @@+concrete CharRegex {+  @type parse (String) -> (optional MatcherTemplate<Char>)+  @type match (MatcherTemplate<Char>,String) -> (Bool)+}
+ example/regex/char-regex.0rx view
@@ -0,0 +1,199 @@+define CharRegex {+  parse (pattern) (matcher) {+    ReadIterator<Char> p <- ReadIterator$$fromReadPosition<Char>(pattern)+    // TODO: Needs error handling.+    { _, matcher } <- parseExpression(p)+  }++  match (template,data) {+    ReadIterator<Char> p <- ReadIterator$$fromReadPosition<Char>(data)+    Matcher<Char> 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<Char>) ->+                      (ReadIterator<Char>,optional ReadSequence<MatcherTemplate<Char>>)+  parseSequence (p) {+    if (p.pastForwardEnd()) {+      return { p, empty }+    }+    { ReadIterator<Char> p2, optional MatcherTemplate<Char> 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<MatcherTemplate<Char>>$create(require(matcher),empty) }+      } else {+        // TODO: Disregards errors from parseNonSequence.+        return { p2, LinkedNode<MatcherTemplate<Char>>$create(MatchEmpty$create(),empty) }+      }+    } if (!present(matcher)) {+      return { p2, empty }+    } else {+      { p2, optional ReadSequence<MatcherTemplate<Char>> sequence } <- parseSequence(p2)+      return { p2, LinkedNode<MatcherTemplate<Char>>$create(require(matcher),sequence) }+    }+  }++  @type parseNonSequence (ReadIterator<Char>) ->+                         (ReadIterator<Char>,optional MatcherTemplate<Char>)+  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<Char>$create(BranchRepeat<Char>$createZeroPlus(require(matcher))) }+      } elif (c == '+') {+        // TODO: Needs error handling.+        return { p2.forward(),+                 MatchBranches<Char>$create(BranchRepeat<Char>$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<Char>$create(BranchRepeat<Char>$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<Char>) -> (ReadIterator<Char>,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<Char>) -> (ReadIterator<Char>,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<Char>) ->+                        (ReadIterator<Char>,optional MatcherTemplate<Char>)+  parseExpression (p) (p2,matcher) {+    optional ReadSequence<MatcherTemplate<Char>> choices <- empty+    p2 <- p+    while (!p2.pastForwardEnd()) {+      { p2, optional ReadSequence<MatcherTemplate<Char>> sequence } <- parseSequence(p2)+      if (!present(sequence)) {+        break+      }+      choices <- LinkedNode<MatcherTemplate<Char>>$create(+          MatchBranches<Char>$create(BranchSequence<Char>$create(sequence)),choices)+      if (p2.pastForwardEnd() || p2.readCurrent() != '|') {+        break+      }+      p2 <- p2.forward()+    }+    if (!present(choices)) {+      matcher <- MatchEmpty$create()+    } else {+      matcher <- MatchChoices<Char>$create(choices)+    }+  }++  @type parseSingleChar (ReadIterator<Char>) ->+                        (ReadIterator<Char>,optional MatcherTemplate<Char>)+  parseSingleChar (p) (p2,matcher) {+    // TODO: Needs error handling.+    Char c <- p.readCurrent()+    p2 <- p.forward()+    if (c == '\\') {+      matcher <- MatchSingle<Char>$create(p2.readCurrent())+      p2 <- p.forward()+    } elif (c == '.') {+      matcher <- MatchAny$create()+    } else {+      matcher <- MatchSingle<Char>$create(c)+    }+  }++  @type parseCharChoices (ReadIterator<Char>) ->+                         (ReadIterator<Char>,optional MatcherTemplate<Char>)+  parseCharChoices (p) (p2,matcher) {+    p2 <- p+    matcher <- empty+    optional Char previous <- empty+    Bool doRange <- false+    optional ReadSequence<MatcherTemplate<Char>> 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<MatcherTemplate<Char>>$create(MatchRange<Char>$create(require(previous),c),choices)+        previous <- empty+        doRange <- false+      } elif (present(previous)) {+        choices <- LinkedNode<MatcherTemplate<Char>>$create(MatchSingle<Char>$create(require(previous)),choices)+        previous <- c+      } else {+        previous <- c+      }+    } update {+      p2 <- p2.forward()+    }+    if (present(previous)) {+      choices <- LinkedNode<MatcherTemplate<Char>>$create(MatchSingle<Char>$create(require(previous)),choices)+    }+    matcher <- MatchChoices<Char>$create(choices)+  }+}
+ example/regex/regex-demo.0rx view
@@ -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<Char> template <- require(CharRegex$parse(pattern))+    ~ LazyStream<Formatted>$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!")+    }+  }+}
+ example/regex/regex-test.0rp view
@@ -0,0 +1,3 @@+concrete RegexTest {+  @type runTests () -> ()+}
+ example/regex/regex-test.0rt view
@@ -0,0 +1,1338 @@+testcase "MatchSingle match" {+  success Test$execute()+}++concrete Test {+  @type execute () -> ()+}++define Test {+  execute () {+    // Pattern: "x"+    MatcherTemplate<Char> template <- MatchSingle<Char>$create('x')+    Matcher<Char> 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<Char> template <- MatchSingle<Char>$create('x')+    Matcher<Char> 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<Char> template <- MatchRange<Char>$create('w','y')+    Matcher<Char> 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<Char> template <- MatchRange<Char>$create('w','y')+    Matcher<Char> 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<Char> template <- MatchAny$create()+    Matcher<Char> 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<Char> template <- MatchEmpty$create()+    Matcher<Char> 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<Char> template <-+        MatchRepeat<Char>$createRange(2,3,MatchRange<Char>$create('w','y'))+    Matcher<Char> 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<Char> template <-+        MatchRepeat<Char>$createRange(2,0,+            MatchRepeat<Char>$createZeroPlus(MatchSingle<Char>$create('x')))+    Matcher<Char> 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<Char> template <-+        MatchRepeat<Char>$createRange(2,3,MatchRange<Char>$create('w','y'))+    Matcher<Char> 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<Char> template <-+        MatchRepeat<Char>$createZeroPlus(+            MatchBranches<Char>$create(+                BranchSequence<Char>$create(+                    LinkedNode<MatcherTemplate<Char>>$create(MatchSingle<Char>$create('a'),+                        LinkedNode<MatcherTemplate<Char>>$create(+                            MatchRepeat<Char>$createZeroPlus(MatchSingle<Char>$create('b')),empty)))))+    Matcher<Char> 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<Char> template <-+        MatchChoices<Char>$create(+            LinkedNode<MatcherTemplate<Char>>$create(MatchRange<Char>$create('w','y'),+                LinkedNode<MatcherTemplate<Char>>$create(+                    MatchBranches<Char>$create(+                        BranchRepeat<Char>$createZeroPlus(MatchSingle<Char>$create('a'))),empty)))+    Matcher<Char> 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<Char> template <-+        MatchChoices<Char>$create(+            LinkedNode<MatcherTemplate<Char>>$create(MatchRange<Char>$create('w','y'),+                LinkedNode<MatcherTemplate<Char>>$create(+                    MatchBranches<Char>$create(+                        BranchRepeat<Char>$createZeroPlus(MatchSingle<Char>$create('a'))),empty)))+    Matcher<Char> 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<Char> template <-+        MatchChoices<Char>$create(+            LinkedNode<MatcherTemplate<Char>>$create(MatchRange<Char>$create('w','y'),+                LinkedNode<MatcherTemplate<Char>>$create(+                    MatchBranches<Char>$create(+                        BranchRepeat<Char>$createRange(2,2,MatchSingle<Char>$create('a'))),+                    LinkedNode<MatcherTemplate<Char>>$create(+                        MatchEmpty$create(),empty))))+    Matcher<Char> 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<Char> template <-+        BranchRepeat<Char>$createRange(2,3,MatchRange<Char>$create('w','y'))+    MatchBrancher<Char> brancher <- template.newBrancher()++    if (template.matchesEmpty()) {+      fail("matches empty")+    }+    if (brancher.matchSatisfied()) {+      fail("match satisfied")+    }++    MatchState state <- MatchState$matchFail()+    optional ReadSequence<MatchBrancher<Char>> 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<Char> template <-+        BranchRepeat<Char>$createRange(2,0,+            MatchBranches<Char>$create(+                BranchRepeat<Char>$createZeroPlus(MatchSingle<Char>$create('x'))))+    MatchBrancher<Char> brancher <- template.newBrancher()++    if (!template.matchesEmpty()) {+      fail("doesn't match empty")+    }+    if (!brancher.matchSatisfied()) {+      fail("match not satisfied")+    }++    MatchState state <- MatchState$matchFail()+    optional ReadSequence<MatchBrancher<Char>> 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<Char> template <-+        BranchRepeat<Char>$createRange(2,3,MatchRange<Char>$create('w','y'))+    MatchBrancher<Char> brancher <- template.newBrancher()++    MatchState state <- MatchState$matchFail()+    optional ReadSequence<MatchBrancher<Char>> 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<Char> template <-+        BranchSequence<Char>$create(+            LinkedNode<MatcherTemplate<Char>>$create(MatchRange<Char>$create('w','y'),+                LinkedNode<MatcherTemplate<Char>>$create(MatchSingle<Char>$create('a'),empty)))+    MatchBrancher<Char> brancher <- template.newBrancher()++    if (template.matchesEmpty()) {+      fail("matches empty")+    }+    if (brancher.matchSatisfied()) {+      fail("match satisfied")+    }++    MatchState state <- MatchState$matchFail()+    optional ReadSequence<MatchBrancher<Char>> 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<Char> template <-+        BranchSequence<Char>$create(+            LinkedNode<MatcherTemplate<Char>>$create(MatchRange<Char>$create('w','y'),+                LinkedNode<MatcherTemplate<Char>>$create(MatchSingle<Char>$create('a'),empty)))+    MatchBrancher<Char> brancher <- template.newBrancher()++    MatchState state <- MatchState$matchFail()+    optional ReadSequence<MatchBrancher<Char>> 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<Char> template <-+        BranchSequence<Char>$create(+            LinkedNode<MatcherTemplate<Char>>$create(+                MatchBranches<Char>$create(+                    BranchRepeat<Char>$createZeroPlus(MatchSingle<Char>$create('a'))),+                LinkedNode<MatcherTemplate<Char>>$create(+                    MatchSingle<Char>$create('b'),empty)))+    MatchBrancher<Char> brancher <- template.newBrancher()++    if (template.matchesEmpty()) {+      fail("matches empty")+    }+    if (brancher.matchSatisfied()) {+      fail("match satisfied")+    }++    MatchState state <- MatchState$matchFail()+    optional ReadSequence<MatchBrancher<Char>> 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<Char> template <-+        BranchSequence<Char>$create(+            LinkedNode<MatcherTemplate<Char>>$create(+                MatchBranches<Char>$create(+                    BranchRepeat<Char>$createOnePlus(MatchSingle<Char>$create('a'))),+                LinkedNode<MatcherTemplate<Char>>$create(+                    MatchSingle<Char>$create('b'),empty)))+    MatchBrancher<Char> brancher <- template.newBrancher()++    if (template.matchesEmpty()) {+      fail("matches empty")+    }+    if (brancher.matchSatisfied()) {+      fail("match satisfied")+    }++    MatchState state <- MatchState$matchFail()+    optional ReadSequence<MatchBrancher<Char>> 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<Char> template <-+        BranchSequence<Char>$create(+            LinkedNode<MatcherTemplate<Char>>$create(+                MatchBranches<Char>$create(+                    BranchRepeat<Char>$createZeroPlus(MatchSingle<Char>$create('a'))),+                LinkedNode<MatcherTemplate<Char>>$create(+                    MatchBranches<Char>$create(+                        BranchRepeat<Char>$createRange(0,2,MatchSingle<Char>$create('a'))),empty)))+    MatchBrancher<Char> brancher <- template.newBrancher()++    if (!template.matchesEmpty()) {+      fail("doesn't match empty")+    }+    if (!brancher.matchSatisfied()) {+      fail("match not satisfied")+    }++    MatchState state <- MatchState$matchFail()+    optional ReadSequence<MatchBrancher<Char>> 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<Char> template <-+        MatchBranches<Char>$create(+            BranchSequence<Char>$create(+                LinkedNode<MatcherTemplate<Char>>$create(MatchRange<Char>$create('w','y'),+                    LinkedNode<MatcherTemplate<Char>>$create(MatchSingle<Char>$create('a'),empty))))+    Matcher<Char> 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<Char> template <-+        MatchBranches<Char>$create(+            BranchSequence<Char>$create(+                LinkedNode<MatcherTemplate<Char>>$create(MatchRange<Char>$create('w','y'),+                    LinkedNode<MatcherTemplate<Char>>$create(MatchSingle<Char>$create('a'),empty))))+    Matcher<Char> 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<Char> templateAB <-+        MatchBranches<Char>$create(+            BranchSequence<Char>$create(+                LinkedNode<MatcherTemplate<Char>>$create(MatchSingle<Char>$create('a'),+                    LinkedNode<MatcherTemplate<Char>>$create(MatchSingle<Char>$create('b'),empty))))+    // Pattern: "ac"+    MatcherTemplate<Char> templateAC <-+        MatchBranches<Char>$create(+            BranchSequence<Char>$create(+                LinkedNode<MatcherTemplate<Char>>$create(MatchSingle<Char>$create('a'),+                    LinkedNode<MatcherTemplate<Char>>$create(MatchSingle<Char>$create('c'),empty))))+    // Pattern: "(ab)*ac"+    MatcherTemplate<Char> template <-+        MatchBranches<Char>$create(+            BranchSequence<Char>$create(+                LinkedNode<MatcherTemplate<Char>>$create(+                    MatchBranches<Char>$create(+                        BranchRepeat<Char>$createZeroPlus(templateAB)),+                    LinkedNode<MatcherTemplate<Char>>$create(templateAC,empty))))+    Matcher<Char> 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<Char> template <-+        MatchBranches<Char>$create(+            BranchRepeat<Char>$createZeroPlus(+                MatchBranches<Char>$create(+                    BranchSequence<Char>$create(+                        LinkedNode<MatcherTemplate<Char>>$create(MatchSingle<Char>$create('a'),+                            LinkedNode<MatcherTemplate<Char>>$create(MatchSingle<Char>$create('b'),empty))))))+    Matcher<Char> 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")+    }+  }+}
+ example/regex/regex.0rp view
@@ -0,0 +1,127 @@+concrete MatchState {+  refines Formatted+  defines Equals<MatchState>+  defines LessThan<MatchState>++  // 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<MatchBrancher<#c>> /*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<any>++  @type create () -> (MatchAny)+}++concrete MatchEmpty {+  refines MatcherTemplate<any>++  @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<MatcherTemplate<#c>>) -> (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<MatcherTemplate<#c>>) -> (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>)+}
+ example/regex/regex.0rx view
@@ -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<any>++  @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<any>++  @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<MatcherTemplate<#c>> choices++  create (choices) {+    return MatchChoices<#c>{ choices }+  }++  matchesEmpty () {+    scoped {+      optional ReadSequence<MatcherTemplate<#c>> 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<MatcherTemplate<#c>>) ->+                            (optional ReadSequence<Matcher<#c>>)+  recursiveNewMatcher (choices) {+    if (!present(choices)) {+      return empty+    }+    return LinkedNode<Matcher<#c>>$create(require(choices).value().newMatcher(),+                                          recursiveNewMatcher(require(choices).next()))+  }+}++concrete MatchChoicesMatcher<#c> {+  refines Matcher<#c>++  @type create (optional ReadSequence<Matcher<#c>>) -> (MatchChoicesMatcher<#c>)+}++define MatchChoicesMatcher {+  @value optional ReadSequence<Matcher<#c>> choices++  create (choices) {+    return MatchChoicesMatcher<#c>{ choices }+  }++  matchSatisfied () {+    scoped {+      optional ReadSequence<Matcher<#c>> 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<Matcher<#c>> 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<MatchBrancher<#c>> branches+  @value Bool complete++  create (brancher) {+    return MatchBranchesMatcher<#c>{ LinkedNode<MatchBrancher<#c>>$create(brancher,empty), false }+  }++  matchSatisfied () {+    if (complete) {+      return true+    }+    scoped {+      optional ReadSequence<MatchBrancher<#c>> 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<MatchBrancher<#c>> current <- branches+    branches <- empty+    complete <- false+    scoped {+    } in while(present(current)) {+      { MatchState state2, optional ReadSequence<MatchBrancher<#c>> branches2 } <-+          require(current).value().tryBranches(data)+      if (state2 `MatchState$equals` MatchState$matchComplete()) {+        complete <- true+      }+      if (state `MatchState$lessThan` state2) {+        state <- state2+      }+      branches <- LinkedNode<MatchBrancher<#c>>$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<BranchRepeatMatcher<#c>>)+}++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<BranchRepeatMatcher<#c>>$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<BranchRepeatMatcher<#c>>$create(self,branch)+      }+    } elif (state `MatchState$equals` MatchState$matchContinue()) {+      branch <- LinkedNode<BranchRepeatMatcher<#c>>$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<MatcherTemplate<#c>> sequence++  create (sequence) {+    return BranchSequence<#c>{ sequence }+  }++  matchesEmpty () {+    scoped {+      optional ReadSequence<MatcherTemplate<#c>> 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<MatcherTemplate<#c>>) -> (BranchSequenceMatcher<#c>)+  @value tryBranches (#c) -> (MatchState,optional ReadSequence<BranchSequenceMatcher<#c>>)+}++define BranchSequenceMatcher {+  @value optional Matcher<#c> continued+  @value optional ReadSequence<MatcherTemplate<#c>> 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<MatcherTemplate<#c>> 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<MatcherTemplate<#c>>) ->+                        (MatchState,optional ReadSequence<BranchSequenceMatcher<#c>>)+  recursiveBranch (data,continued,sequence) (state,branch) {+    state <- MatchState$matchFail()+    branch <- empty+    if (!present(continued) && !present(sequence)) {+      return _+    }+    optional Matcher<#c> continued2 <- continued+    optional ReadSequence<MatcherTemplate<#c>> 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<BranchSequenceMatcher<#c>>$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<BranchSequenceMatcher<#c>>$create(+            BranchSequenceMatcher<#c>{ empty, empty, false },branch)+      }+    } elif (state `MatchState$equals` MatchState$matchContinue()) {+        // Add a branch to continue this sequence.+        branch <- LinkedNode<BranchSequenceMatcher<#c>>$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+  }+}
+ example/tree/README.md view
@@ -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+```
+ example/tree/tree-demo.0rx view
@@ -0,0 +1,54 @@+concrete TreeDemo {+  @type run () -> ()+}++define TreeDemo {+  run () {+    TypeTree tree <- TypeTree$new()++    TypeKey<Int>    keyInt    <- TypeKey<Int>$new()+    TypeKey<String> keyString <- TypeKey<String>$new()+    TypeKey<Float>  keyFloat  <- TypeKey<Float>$new()+    TypeKey<Value>  keyValue  <- TypeKey<Value>$new()++    ~ tree.set<Int>(keyInt,1)+    ~ tree.set<String>(keyString,"a")++    ~ check<Int>(tree,keyInt)+    ~ check<String>(tree,keyString)+    ~ check<Float>(tree,keyFloat)  // Not found, since we never added a value.++    ~ tree.set<Value>(keyValue,Value$new())+    ~ check<Value>(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<Formatted>$new()+          .append("Found '")+          .append(require(value))+          .append("'\n")+          .writeTo(SimpleOutput$stderr())+    } else {+      ~ LazyStream<Formatted>$new()+          .append(typename<TypeKey<#x>>())+          .append(" Not Found\n")+          .writeTo(SimpleOutput$stderr())+    }+  }+}++concrete Value {+  refines Formatted+  @type new () -> (Value)+}++define Value {+  new () { return Value{} }+  formatted () { return "Value" }+}
+ example/tree/tree-test.0rt view
@@ -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<Int,Int>&KVReader<Int,Int>] tree <- Tree<Int,Int>$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<Formatted>$new()+            .append("Not found ")+            .append(new)+            .append(" but should have been ")+            .append(i)+            .writeTo(SimpleOutput$error())+      } elif (require(value) != i) {+        ~ LazyStream<Formatted>$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+    }+  }+}
+ example/tree/tree.0rp view
@@ -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>)+}
+ example/tree/tree.0rx view
@@ -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 }+}
+ example/tree/type-tree.0rp view
@@ -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<any>) -> (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<V> can be used as TypeKey<I>.+ */+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<TypeKey<any>>.+  //+  // This is non-trivial:+  //+  // - #x -> any, which is trivial.+  // - TypeKey<#x> -> TypeKey<any>, since TypeKey has a single covariant param.+  // - LessThan<TypeKey<any>> -> LessThan<TypeKey<#x>>, since LessThan has a+  //   single contravariant param.+  // - TypeKey<#x> -> LessThan<TypeKey<any>> -> LessThan<TypeKey<#x>>.+  //+  // This means that TypeKey<#x> can be used as a key in Tree. (See tree.0rp.)+  defines LessThan<TypeKey<any>>+  defines Equals<TypeKey<any>>++  // Creates a new TypeKey, e.g., TypeTree<#x>$new().+  @type new () -> (TypeKey<#x>)+}
+ example/tree/type-tree.0rx view
@@ -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<TypeKey<any>,LockedType<any>> tree++  new () {+    return TypeTree{ Tree<TypeKey<any>,LockedType<any>>$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<any> 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<any>$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+    }+  }+}
+ lib/file/.zeolite-module view
@@ -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 = ""}
+ lib/file/Category_RawFileReader.cpp view
@@ -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 <fstream>++#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<TypeValue> 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<Category_RawFileReader>::Check();+    CycleCheck<Category_RawFileReader> 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<const TypeInstance*> 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<const TypeInstance*>& args) const final {+    if (&category == &GetCategory_RawFileReader()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_PersistentResource()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_BlockReader()) {+      args = std::vector<const TypeInstance*>{&GetType_String(T_get())};+      return true;+    }+    return false;+  }+  Type_RawFileReader(Category_RawFileReader& p, Params<0>::Type params) : parent(p) {+    CycleCheck<Type_RawFileReader>::Check();+    CycleCheck<Type_RawFileReader> 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<TypeValue>& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final {+    using CallType = ReturnTuple(Value_RawFileReader::*)(const S<TypeValue>&, 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<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_getFileError(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_pastEnd(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_readBlock(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  Type_RawFileReader& parent;++  R<std::istream> file;+};+S<TypeValue> 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<TypeValue>& 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<TypeValue>& 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<TypeValue>& 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<TypeValue>& 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
+ lib/file/Category_RawFileWriter.cpp view
@@ -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 <fstream>++#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<TypeValue> 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<Category_RawFileWriter>::Check();+    CycleCheck<Category_RawFileWriter> 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<const TypeInstance*> 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<const TypeInstance*>& args) const final {+    if (&category == &GetCategory_RawFileWriter()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_PersistentResource()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_BlockWriter()) {+      args = std::vector<const TypeInstance*>{&GetType_String(T_get())};+      return true;+    }+    return false;+  }+  Type_RawFileWriter(Category_RawFileWriter& p, Params<0>::Type params) : parent(p) {+    CycleCheck<Type_RawFileWriter>::Check();+    CycleCheck<Type_RawFileWriter> 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<TypeValue>& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final {+    using CallType = ReturnTuple(Value_RawFileWriter::*)(const S<TypeValue>&, 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<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_getFileError(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  ReturnTuple Call_writeBlock(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args);+  Type_RawFileWriter& parent;++  R<std::ostream> file;+};+S<TypeValue> 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<TypeValue>& 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<TypeValue>& 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<TypeValue>& 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
+ lib/file/file.0rp view
@@ -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<String>++  @type open (String) -> (RawFileReader)+  @value getFileError () -> (optional String)+}++concrete RawFileWriter {+  refines PersistentResource+  refines BlockWriter<String>++  @type open (String) -> (RawFileWriter)+  @value getFileError () -> (optional String)+}
+ lib/file/tests.0rt view
@@ -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 () -> ()+}
+ lib/util/.zeolite-module view
@@ -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 = ""}
+ lib/util/Category_Argv.cpp view
@@ -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<TypeValue>& 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<TypeValue> 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<Category_Argv>::Check();+    CycleCheck<Category_Argv> 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<const TypeInstance*> 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<const TypeInstance*>& args) const final {+    if (&category == &GetCategory_Argv()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    if (&category == &GetCategory_ReadPosition()) {+      args = std::vector<const TypeInstance*>{&GetType_String(T_get())};+      return true;+    }+    return false;+  }+  Type_Argv(Category_Argv& p, Params<0>::Type params) : parent(p) {+    CycleCheck<Type_Argv>::Check();+    CycleCheck<Type_Argv> 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<TypeValue>& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final {+    using CallType = ReturnTuple(Value_Argv::*)(const S<TypeValue>&, 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<TypeValue>& 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<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args) {+    TRACE_FUNCTION("Argv.readSize")+    return ReturnTuple(Box_Int(Argv::ArgCount()));+  }+  Type_Argv& parent;+};+S<TypeValue> CreateValue(Type_Argv& parent, const ParamTuple& params, const ValueTuple& args) {+  return S_get(new Value_Argv(parent, params, args));+}++const S<TypeValue>& Var_global = *new S<TypeValue>(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
+ lib/util/Category_SimpleInput.cpp view
@@ -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 <unistd.h>++#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<TypeValue>& 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<TypeValue> 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<Category_SimpleInput>::Check();+    CycleCheck<Category_SimpleInput> 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<const TypeInstance*> 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<const TypeInstance*>& args) const final {+    if (&category == &GetCategory_SimpleInput()) {+      args = std::vector<const TypeInstance*>{};+      return true;+    }+    return false;+  }+  Type_SimpleInput(Category_SimpleInput& p, Params<0>::Type params) : parent(p) {+    CycleCheck<Type_SimpleInput>::Check();+    CycleCheck<Type_SimpleInput> 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<TypeValue>& 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<TypeValue> CreateValue(Type_SimpleInput& parent, const ParamTuple& params, const ValueTuple& args) {+  return S_get(new Value_SimpleInput(parent, params, args));+}++const S<TypeValue>& Var_stdin = *new S<TypeValue>(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
+ lib/util/Category_SimpleOutput.cpp view
@@ -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 <iostream>+#include <sstream>++#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<TypeValue>& Var_stdout;+extern const S<TypeValue>& Var_stderr;+extern const S<TypeValue>& 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<TypeValue>& 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<TypeValue>& 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<TypeValue>& Var_stdout = *new S<TypeValue>(new Value_SimpleOutput(std::cout));+const S<TypeValue>& Var_stderr = *new S<TypeValue>(new Value_SimpleOutput(std::cerr));+const S<TypeValue>& Var_error  = *new S<TypeValue>(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
+ lib/util/tests.0rt view
@@ -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<Formatted>$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<Formatted>$new().append("message").writeTo(SimpleOutput$stderr())+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "error writer" {+  crash Test$run()+  require "message"+}++define Test {+  run () {+    ~ LazyStream<Formatted>$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<Char> iter <- ReadIterator$$fromReadPosition<Char>(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<Char> iter <- ReadIterator$$fromReadPositionAt<Char>(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<Formatted>$new()+        .append(name)+        .append("\n")+        .writeTo(SimpleOutput$stdout())+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "TextReader splits lines correctly" {+  success Test$run()+}++concrete FakeFile {+  refines BlockReader<String>++  @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 () -> ()+}
+ lib/util/util.0rp view
@@ -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<ReadIterator<#x>>+  refines IterateReverse<ReadIterator<#x>>++  @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<Formatted>)+  @type stderr () -> (BufferedWriter<Formatted>)+  @type error () -> (BufferedWriter<Formatted>)+}++concrete SimpleInput {+  @type stdin () -> (BlockReader<String>)+}++concrete Argv {+  refines ReadPosition<String>++  @type global () -> (ReadPosition<String>)+}++@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<String>) -> (TextReader)+  @value readNextLine () -> (String)+  @value pastEnd () -> (Bool)+}
+ lib/util/util.0rx view
@@ -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<Formatted>$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<String> 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+  }+}
+ src/Base/CompileError.hs view
@@ -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
+ src/Base/Mergeable.hs view
@@ -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 (++) []
+ src/Cli/CompileMetadata.hs view
@@ -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]
+ src/Cli/CompileOptions.hs view
@@ -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
+ src/Cli/Compiler.hs view
@@ -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
+ src/Cli/ParseCompileOptions.hs view
@@ -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
+ src/Cli/TestRunner.hs view
@@ -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)
+ src/Compilation/CompileInfo.hs view
@@ -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)
+ src/Compilation/CompilerState.hs view
@@ -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
+ src/Compilation/ProcedureContext.hs view
@@ -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)
+ src/Compilation/ScopeContext.hs view
@@ -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)+  ]
+ src/CompilerCxx/Category.hs view
@@ -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<TypeValue>& 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<TypeValue>&, 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<const TypeInstance*> 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<const TypeInstance*>& 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<const TypeInstance*>{" ++ 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<TypeValue> " ++ 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<TypeValue> " ++ 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)
+ src/CompilerCxx/CategoryContext.hs view
@@ -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 [] []+  }
+ src/CompilerCxx/Code.hs view
@@ -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<TypeValue>"+  | otherwise                = "S<TypeValue>"++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<TypeValue>&"+  | otherwise                = "S<TypeValue>&"++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 ++ "\""
+ src/CompilerCxx/Naming.hs view
@@ -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"
+ src/CompilerCxx/Procedure.hs view
@@ -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<TypeValue>& 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<TypeValue>& 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
+ src/Config/LoadConfig.hs view
@@ -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 [p</>m,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
+ src/Config/Paths.hs view
@@ -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
+ src/Config/Programs.hs view
@@ -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)
+ src/Parser/Common.hs view
@@ -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)
+ src/Parser/DefinedCategory.hs view
@@ -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])
+ src/Parser/IntegrationTest.hs view
@@ -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
+ src/Parser/Procedure.hs view
@@ -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
+ src/Parser/SourceFile.hs view
@@ -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
+ src/Parser/TypeCategory.hs view
@@ -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<a,b,c>+      inv <- between (sepAfter $ string "<")+                     (sepAfter $ string ">")+                     (sepBy singleParam (sepAfter $ string ","))+      return ([],inv,[])+    noFixed = do -- T<a,b|c,d>+      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<a,b|c,d|e,f>+      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
+ src/Parser/TypeInstance.hs view
@@ -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
+ src/Test/Common.hs view
@@ -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)
+ src/Test/DefinedCategory.hs view
@@ -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"
+ src/Test/IntegrationTest.hs view
@@ -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
+ src/Test/Parser.hs view
@@ -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"
+ src/Test/Procedure.hs view
@@ -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 ()
+ src/Test/TypeCategory.hs view
@@ -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<T> {}",+    checkShortParseFail "concrete Type<optional> {}",+    checkShortParseFail "concrete Type<optional T> {}",+    checkShortParseFail "concrete Type<T<#x>> {}",+    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<Object2>>"),+            ("Parent","Object3<Object3<Object2>>"),+            ("Parent","Object2"),+            ("Child","Parent<Child>"),+            ("Child","Object1<Child,Object3<Object2>>"),+            ("Child","Object3<Object3<Object2>>"),+            ("Child","Object2")+          ]+        scrapeAllDefines ts `containsExactly` [+            ("Child","Type<Child>")+          ]),++    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<Object2>"]),+    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<Type<#t>,#b,Type3<#x>,#d,#e,#f>"+        checkPaired containsExactly rs [+            ["allows Parent"],+            ["requires Type2<Type<#t>>"],+            ["defines Equals<Type3<#x>>"],+            [],+            [],+            []+          ]),++    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<Type<#t>,#b,Type3<#x>,#d,#e,#f>"+        checkPaired containsExactly rs [+            ["allows Parent"],+            ["requires Type2<Type<#t>>"],+            ["defines Equals<Type3<#x>>"],+            [],+            [],+            []+          ]),++    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<Type<#t>,#b,Type3<#x>,#d,#e,#f>"+        checkPaired containsExactly rs [+            ["allows Parent"],+            ["requires Type2<Type<#t>>"],+            ["defines Equals<Type3<#x>>"],+            [],+            [],+            []+          ]),++    -- 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<Child>"),+    checkOperationSuccess+      ("testfiles" </> "flatten.0rx")+      (\ts -> do+        ts <- topoSortCategories defaultCategories ts+        ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories+        let r = CategoryResolver ta+        checkTypeFail r [] "[Type<Child>|Type<Child>]"),+    checkOperationSuccess+      ("testfiles" </> "flatten.0rx")+      (\ts -> do+        ts <- topoSortCategories defaultCategories ts+        ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories+        let r = CategoryResolver ta+        checkTypeFail r [] "[Type<Child>&Type<Child>]"),++    -- 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<Value1,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 [] "Value0<Value1,Value1>"),+    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<Value3,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",[]),("#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<Value1,Value1>","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<Child>","Object2",+                              "Object1<Child,Object3<Object2>>",+                              "Object3<Object3<Object2>>"]),++    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"
+ src/Test/TypeInstance.hs view
@@ -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>"+      "Type0",+    checkSimpleConvertFail+      "Type0"+      "Type1<Type0>",+    checkSimpleConvertSuccess+      "Type2<Type0,Type0,Type0>"+      "Type2<Type0,Type0,Type0>",+    checkSimpleConvertSuccess+      "Type2<Type0,Type0,Type3>"+      "Type2<Type3,Type0,Type0>",+    checkSimpleConvertFail+      "Type2<Type3,Type0,Type3>"+      "Type2<Type0,Type0,Type0>",+    checkSimpleConvertFail+      "Type2<Type0,Type0,Type0>"+      "Type2<Type3,Type0,Type3>",+    checkSimpleConvertFail+      "Type2<Type0,Type3,Type0>"+      "Type2<Type0,Type0,Type0>",+    checkSimpleConvertFail+      "Type2<Type0,Type0,Type0>"+      "Type2<Type0,Type3,Type0>",+    checkSimpleConvertSuccess+      "Type3"+      "[Type0|Type3]",+    checkSimpleConvertSuccess+      "Type3"+      "[Type0|Type1<Type0>]",+    checkSimpleConvertSuccess+      "[Type3|Type1<Type0>]"+      "Type0",+    checkSimpleConvertSuccess+      "[Type0&Type3]"+      "Type3",+    checkSimpleConvertSuccess+      "[Type3|Type3]"+      "Type3",+    checkSimpleConvertSuccess+      "[Type1<Type0>&Type3]"+      "[Type1<Type0>|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<Type0>"+      "Type1<any>",+    checkSimpleConvertFail+      "Type1<all>"+      "Type1<Type0>",++    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<Type0,Type0,#x>" "Type2<Type0,Type0,#x>",+    checkConvertFail+      [("#x",[]),+       ("#y",[])]+      "Type2<Type0,Type0,#x>" "Type2<Type0,Type0,#y>",+    checkConvertSuccess+      [("#x",["requires #y"]),+       ("#y",["allows #x"])]+      "Type2<Type0,Type0,#x>" "Type2<Type0,Type0,#y>",+    checkConvertSuccess+      [("#x",["requires #y"]),+       ("#y",[])]+      "Type2<Type0,Type0,#x>" "Type2<Type0,Type0,#y>",+    checkConvertSuccess+      [("#x",[]),+       ("#y",["allows #x"])]+      "Type2<Type0,Type0,#x>" "Type2<Type0,Type0,#y>",++    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<Type0,Type0,Type0>",+    checkConvertSuccess+      [("#x",["allows Type0"])]+      "Type2<#x,Type0,Type0>" "Type2<Type0,Type0,Type0>",+    checkConvertSuccess+      [("#x",["allows Type0"])]+      "Type2<#x,Type0,Type0>" "Type2<Type3,Type0,Type0>",+    checkConvertFail+      [("#x",[])]+      "Type2<Type0,Type0,Type0>" "Type2<#x,Type0,Type0>",+    checkConvertSuccess+      [("#x",["requires Type0"])]+      "Type2<Type0,Type0,Type0>" "Type2<#x,Type0,Type0>",+    checkConvertSuccess+      [("#x",["requires Type3"])]+      "Type2<Type0,Type0,Type0>" "Type2<#x,Type0,Type0>",++    return $ checkTypeSuccess Resolver+      []+      "Type4<Type0>",+    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<all>",+    return $ checkTypeSuccess Resolver+      [("#x",["requires Type3","defines Instance0"])]+      "Type1<#x>",+    return $ checkTypeSuccess Resolver+      []+      "Type1<Type3>",+    return $ checkTypeFail Resolver+      []+      "Type1<Type1<Type3>>",+    return $ checkTypeSuccess Resolver+      []+      "Type2<Type0,Type0,Type0>",+    return $ checkTypeFail Resolver+      []+      "Type2<all,Type0,Type0>",+    return $ checkTypeFail Resolver+      []+      "Type2<any,Type0,Type0>",+    return $ checkTypeSuccess Resolver+      []+      "Type4<any>",+    return $ checkTypeFail Resolver+      []+      "Type4<all>",++    return $ checkTypeSuccess Resolver+      [("#x",["defines Instance1<Type0>",+             "defines Instance1<#x>",+             "defines Instance1<Type3>"])]+      "Type2<#x,#x,#x>",+    return $ checkTypeFail Resolver+      [("#x",["defines Instance1<#x>",+             "defines Instance1<Type3>"])]+      "Type2<#x,#x,#x>",+    return $ checkTypeFail Resolver+      [("#x",["defines Instance1<Type0>",+             "defines Instance1<Type3>"])]+      "Type2<#x,#x,#x>",+    return $ checkTypeSuccess Resolver+      [("#x",["defines Instance1<Type0>",+             "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<Type0>",+    return $ checkTypeFail Resolver+      []+      "Type5<#x>",+    return $ checkTypeSuccess Resolver+      [("#x",[])]+      "Type5<#x>",++    return $ checkTypeSuccess Resolver+      []+      "[Type4<Type0>|Type1<Type3>]",+    return $ checkTypeSuccess Resolver+      []+      "[Type4<Type0>&Type1<Type3>]",+    return $ checkTypeSuccess Resolver+      [("#x",[])]+      "[Type5<#x>|Type1<Type3>]",+    return $ checkTypeSuccess Resolver+      [("#x",[])]+      "[Type5<#x>&Type1<Type3>]",+    return $ checkTypeSuccess Resolver+      [("#x",[])]+      "[#x|Type1<Type3>]",+    return $ checkTypeSuccess Resolver+      [("#x",[])]+      "[#x&Type1<Type3>]",+    return $ checkTypeFail Resolver+      [("#x",[])]+      "[Type4<Type0>|Instance0]",+    return $ checkTypeFail Resolver+      [("#x",[])]+      "[Type4<Type0>&Instance0]",++    return $ checkTypeSuccess Resolver+      []+      "[[Type4<Type0>&Type1<Type3>]|Type1<Type3>]",+    return $ checkTypeSuccess Resolver+      []+      "[[Type4<Type0>|Type1<Type3>]&Type1<Type3>]",+    return $ checkTypeSuccess Resolver+      [("#x",[])]+      "[[Type4<Type0>&#x]|Type1<Type3>]",+    return $ checkTypeSuccess Resolver+      [("#x",[])]+      "[[Type4<Type0>|#x]&Type1<Type3>]",++    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<Type3>",+    return $ checkDefinesSuccess Resolver+      []+      "Instance1<Type1<Type3>>"+  ]+++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<x>+    (type2,Positional [Contravariant,Invariant,Covariant]), -- Type2<x|y|z>+    (type3,Positional []), -- Type3<>+    (type4,Positional [Invariant]), -- Type4<x>+    (type5,Positional [Invariant]), -- Type5<x>+    (instance0,Positional []), -- Instance0<>+    (instance1,Positional [Contravariant]) -- Instance1<x|>+  ]++refines :: Map.Map CategoryName (Map.Map CategoryName (InstanceParams -> InstanceParams))+refines = Map.fromList $ [+    (type0,Map.fromList $ []),+    (type1,Map.fromList $ [+        -- Type1<x> -> Type0+        (type0,\(Positional [_]) ->+               Positional [])+      ]),+    (type2,Map.fromList $ [+        -- Type2<x,y,z> -> Type0 (inherited from Type1)+        (type0,\(Positional [_,_,_]) ->+               Positional []),+        -- Type2<x,y,z> -> Type1<x>+        (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<Type0>+        (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<Type3>+             [forceParse $ "defines Instance1<Type3>"],+             -- y defines Instance1<y>+             [forceParse $ "defines Instance1<" ++ show y ++ ">"],+             -- z defines Instance1<Type0>+             [forceParse $ "defines Instance1<Type0>"]+           ]),+    (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"
+ src/Test/testfiles/ambiguous_merge_inherit.0rx view
@@ -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<Type2>+  refines Interface2++  something (Type2) -> (Type2)+}++@value interface Test2 {+  refines Interface1<Type3>+  refines Test1++  // something must be merged again, since Interface1 is inherited again.+}
+ src/Test/testfiles/bad_allows_variance_left.0rx view
@@ -0,0 +1,5 @@+@value interface Interface {}++concrete Type<|#x> {+  #x allows Interface+}
+ src/Test/testfiles/bad_allows_variance_right.0rx view
@@ -0,0 +1,5 @@+@value interface Interface<|#x> {}++concrete Type<#x|> {+  #x allows Interface<#x>+}
+ src/Test/testfiles/bad_defines_variance_left.0rx view
@@ -0,0 +1,5 @@+@type interface Interface {}++concrete Type<#x|> {+  #x defines Interface+}
+ src/Test/testfiles/bad_defines_variance_right.0rx view
@@ -0,0 +1,5 @@+@type interface Interface<|#x> {}++concrete Type<|#x> {+  #x defines Interface<#x>+}
+ src/Test/testfiles/bad_requires_variance_left.0rx view
@@ -0,0 +1,5 @@+@value interface Interface {}++concrete Type<#x|> {+  #x requires Interface+}
+ src/Test/testfiles/bad_requires_variance_right.0rx view
@@ -0,0 +1,5 @@+@value interface Interface<|#x> {}++concrete Type<|#x> {+  #x requires Interface<#x>+}
+ src/Test/testfiles/bad_type_arg_variance.0rx view
@@ -0,0 +1,6 @@+@value interface Type1<#x|> {}++@type interface Type2<#x|> {+  // contravariant * contravariant = covariant+  something (Type1<#x>) -> ()+}
+ src/Test/testfiles/bad_type_return_variance.0rx view
@@ -0,0 +1,5 @@+@value interface Type1<#x|> {}++@type interface Type2<|#x> {+  something () -> (Type1<#x>)+}
+ src/Test/testfiles/bad_value_arg_variance.0rx view
@@ -0,0 +1,6 @@+@value interface Type1<#x|> {}++@value interface Type2<#x|> {+  // contravariant * contravariant = covariant+  something (Type1<#x>) -> ()+}
+ src/Test/testfiles/bad_value_return_variance.0rx view
@@ -0,0 +1,5 @@+@value interface Type1<#x|> {}++@value interface Type2<|#x> {+  something () -> (Type1<#x>)+}
+ src/Test/testfiles/basic_crash_test.0rt view
@@ -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 () { }+}
+ src/Test/testfiles/basic_error_test.0rt view
@@ -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 () { }+}
+ src/Test/testfiles/basic_success_test.0rt view
@@ -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 () { }+}
+ src/Test/testfiles/category_function_param_match.0rx view
@@ -0,0 +1,4 @@+concrete Type<#x> {+  @category something<#x>+  () -> ()+}
+ src/Test/testfiles/concrete.0rx view
@@ -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<Type2<#a>,#f>+  defines /* <- used with type interfaces */ Equals<Type<#a,#b,#c,#d,#e,#f>>+  #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<Type3>+  () -> (optional Type1<Type3>)++  @type create2<#y>+    #y requires #x+    #y allows T2+    #y defines T3+  () -> (optional #x)++  @value get () -> (Type1<Type3>)+  @value set (Type1<Type3>) -> ()+}
+ src/Test/testfiles/concrete_defines_concrete.0rx view
@@ -0,0 +1,5 @@+concrete Parent {}++concrete Child {+  defines Parent+}
+ src/Test/testfiles/concrete_defines_instance.0rx view
@@ -0,0 +1,5 @@+@type interface Parent {}++concrete Child {+  defines Parent+}
+ src/Test/testfiles/concrete_defines_value.0rx view
@@ -0,0 +1,5 @@+@value interface Parent {}++concrete Child {+  defines Parent+}
+ src/Test/testfiles/concrete_duplicate_param.0rx view
@@ -0,0 +1,1 @@+concrete Type<#x|#y|#x> {}
+ src/Test/testfiles/concrete_instances.0rx view
@@ -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<Value0>+}+++// Tests.++concrete Object0 {+  refines Value2 // -> Value0+  defines Type<Object0>+  refines Value1<Object0>+}++concrete Object1 {+  defines Type<Value0>+  refines Value3<Object1>+}
+ src/Test/testfiles/concrete_missing_define.0rx view
@@ -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<Value0>+}+++// Tests.++concrete Object1 {+  refines Value3<Object1>+}
+ src/Test/testfiles/concrete_missing_refine.0rx view
@@ -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<Object0>+  refines Value1<Object0>+}
+ src/Test/testfiles/concrete_refines_concrete.0rx view
@@ -0,0 +1,5 @@+concrete Parent {}++concrete Child {+  refines Parent+}
+ src/Test/testfiles/concrete_refines_instance.0rx view
@@ -0,0 +1,5 @@+@type interface Parent {}++concrete Child {+  refines Parent+}
+ src/Test/testfiles/concrete_refines_value.0rx view
@@ -0,0 +1,5 @@+@value interface Parent {}++concrete Child {+  refines Parent+}
+ src/Test/testfiles/conflict_in_preserved.0rx view
@@ -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+}
+ src/Test/testfiles/conflicting_declaration.0rx view
@@ -0,0 +1,4 @@+concrete Type {+  @type something () -> ()+  @value something () -> (Type)+}
+ src/Test/testfiles/conflicting_inherited.0rx view
@@ -0,0 +1,12 @@+@value interface Type1 {+  something () -> ()+}++@value interface Type2 {+  something () -> (Type)+}++concrete Type3 {+  refines Type1+  refines Type2+}
+ src/Test/testfiles/contravariant_defines_covariant.0rx view
@@ -0,0 +1,5 @@+@type interface Object1<|#x> {}++concrete Object2<#y|> {+  defines Object1<#y>+}
+ src/Test/testfiles/contravariant_defines_invariant.0rx view
@@ -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<Object1<#y>>+}
+ src/Test/testfiles/contravariant_refines_covariant.0rx view
@@ -0,0 +1,5 @@+@value interface Object1<|#x> {}++@value interface Object2<#y|> {+  refines Object1<#y>+}
+ src/Test/testfiles/contravariant_refines_invariant.0rx view
@@ -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<Object1<#y>>+}
+ src/Test/testfiles/covariant_defines_contravariant.0rx view
@@ -0,0 +1,5 @@+@type interface Object1<#x|> {}++concrete Object2<|#y> {+  defines Object1<#y>+}
+ src/Test/testfiles/covariant_defines_invariant.0rx view
@@ -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<Object1<#y>>+}
+ src/Test/testfiles/covariant_refines_contravariant.0rx view
@@ -0,0 +1,5 @@+@value interface Object1<#x|> {}++@value interface Object2<|#y> {+  refines Object1<#y>+}
+ src/Test/testfiles/covariant_refines_invariant.0rx view
@@ -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<Object1<#y>>+}
+ src/Test/testfiles/definitions.0rx view
@@ -0,0 +1,17 @@+define Type {+  @value T<#x> val++  @type Type<#x> zzz <- Type<#x>{ T<#x>$create() }++  @category optional T<any> something <- skip++  get () {+    return val+  }++  @value get2 () -> (T<#x>)+  get2 () (v) {+    v <- val+    return _+  }+}
+ src/Test/testfiles/duplicate_define.0rx view
@@ -0,0 +1,12 @@+@value interface Value0 {}++@value interface Value1 {+  refines Value0+}++@type interface Type0<|#x> {}++concrete Object {+  defines Type0<Value0>+  defines Type0<Value1>+}
+ src/Test/testfiles/duplicate_refine.0rx view
@@ -0,0 +1,12 @@+@value interface Value0 {}++@value interface Value1 {+  refines Value0+}++@value interface Value2<|#x> {}++concrete Object {+  refines Value2<Value0>+  refines Value2<Value1>+}
+ src/Test/testfiles/failed_merge.0rx view
@@ -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)+}
+ src/Test/testfiles/failed_merge_params.0rx view
@@ -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)+}
+ src/Test/testfiles/filters.0rx view
@@ -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<Value1,Value2>+}++concrete Value2 {+  refines Value3+  defines Equals<Value2>+}++concrete Value3 {+  refines Value1+}
+ src/Test/testfiles/flatten.0rx view
@@ -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<Object2>>+  // -> refines Object3<Object3<Object2>>+  // -> refines Object2+}++@type interface Type<#x> {}++concrete Child {+  refines Parent<Child>+  // -> refines Object1<Child,Object3<Object2>>+  // -> refines Object3<Object3<Object2>>+  // -> refines Object2++  defines Type<Child>+}
+ src/Test/testfiles/function_allows_missed.0rx view
@@ -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>)+}
+ src/Test/testfiles/function_bad_allows_type.0rx view
@@ -0,0 +1,9 @@+@value interface Interface<#x> {+  #x requires Formatted+}++concrete Type<#x> {+  @type something<#y>+    #y allows Interface<#x>+  () -> ()+}
+ src/Test/testfiles/function_bad_allows_variance.0rx view
@@ -0,0 +1,7 @@+@value interface Interface<#x|> {}++concrete Type<|#x> {+  @value something<#y>+    #y allows Interface<#x>+  () -> ()+}
+ src/Test/testfiles/function_bad_arg.0rx view
@@ -0,0 +1,9 @@+@value interface Type0 {}++@value interface Type1<#x> {+  #x requires Type0+}++concrete Type<x> {+  @value something (Type1<#x>) -> ()+}
+ src/Test/testfiles/function_bad_defines_type.0rx view
@@ -0,0 +1,9 @@+@type interface Interface<#x> {+  #x requires Formatted+}++concrete Type<#x> {+  @type something<#y>+    #y defines Interface<#x>+  () -> ()+}
+ src/Test/testfiles/function_bad_defines_variance.0rx view
@@ -0,0 +1,7 @@+@type interface Interface<|#x> {}++concrete Type<|#x> {+  @value something<#y>+    #y defines Interface<#x>+  () -> ()+}
+ src/Test/testfiles/function_bad_filter_param.0rx view
@@ -0,0 +1,5 @@+concrete Type {+  @value something<x>+    y allows Type+  () -> ()+}
+ src/Test/testfiles/function_bad_requires_type.0rx view
@@ -0,0 +1,9 @@+@type interface Interface<#x> {+  #x requires Formatted+}++concrete Type<#x> {+  @type something<#y>+    #y requires Interface<#x>+  () -> ()+}
+ src/Test/testfiles/function_bad_requires_variance.0rx view
@@ -0,0 +1,7 @@+@value interface Interface<|#x> {}++concrete Type<|#x> {+  @value something<#y>+    #y requires Interface<#x>+  () -> ()+}
+ src/Test/testfiles/function_bad_return.0rx view
@@ -0,0 +1,9 @@+@value interface Type0 {}++@value interface Type1<#x> {+  #x requires Type0+}++concrete Type<x> {+  @value something () -> (Type1<#x>)+}
+ src/Test/testfiles/function_defines_missed.0rx view
@@ -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>)+}
+ src/Test/testfiles/function_duplicate_param.0rx view
@@ -0,0 +1,4 @@+concrete Type {+  @value something<#x,#x>+  () -> ()+}
+ src/Test/testfiles/function_filters_satisfied.0rx view
@@ -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>)+}
+ src/Test/testfiles/function_param_clash.0rx view
@@ -0,0 +1,4 @@+concrete Type<#x> {+  @value something<#x>+  () -> ()+}
+ src/Test/testfiles/function_requires_missed.0rx view
@@ -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>)+}
+ src/Test/testfiles/inherit_incompatible.0rx view
@@ -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<Child1>+}++@value interface Parent2 {+  refines Inherit<Child2>+}++concrete Test {+  refines Parent1+  refines Parent2+}
+ src/Test/testfiles/internal_filters.0rx view
@@ -0,0 +1,7 @@+define Type {+  types<#x,#y,#z> {+    #x requires Type1+    #y allows Type2+    #z defines Type3+  }+}
+ src/Test/testfiles/internal_inheritance.0rx view
@@ -0,0 +1,4 @@+define Type {+  refines Formatted+  defines LessThan<Type>+}
+ src/Test/testfiles/internal_params.0rx view
@@ -0,0 +1,3 @@+define Type {+  types<#x,#y,#z> {}+}
+ src/Test/testfiles/merge_different_scopes.0rx view
@@ -0,0 +1,14 @@+@value interface Type1 {+  something () -> ()+}++@type interface Type2 {+  something () -> ()+}++concrete Type3 {+  refines Type1+  defines Type2++  @value something () -> ()+}
+ src/Test/testfiles/merge_incompatible.0rx view
@@ -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<Child1>+}++@value interface Parent2 {+  refines Inherit<Child2>+}++concrete Test {+  refines Parent1+  refines Parent2+  refines Inherit<Base>+}
+ src/Test/testfiles/merge_with_refine.0rx view
@@ -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)+}
+ src/Test/testfiles/merged.0rx view
@@ -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<Value1,Value1>+}++@value interface Inherit2 {+  refines Value4<Value2,Value0>+}++concrete Test {+  refines Value0+  refines Value1+  refines Value2 // -> Value1 -> Value0+  refines Value3 // -> Value0++  refines Inherit1+  refines Inherit2+}
+ src/Test/testfiles/partial.0rx view
@@ -0,0 +1,5 @@+concrete Child {+  refines Parent+  // -> Object1+  // -> Object2+}
+ src/Test/testfiles/partial_params.0rx view
@@ -0,0 +1,3 @@+concrete Child<#x|#y> {+  refines Parent<#x,#y>+}
+ src/Test/testfiles/preserve_merged.0rx view
@@ -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+}
+ src/Test/testfiles/procedures.0rx view
@@ -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) {}
+ src/Test/testfiles/refine_wrong_direction.0rx view
@@ -0,0 +1,16 @@+@value interface Type1 {}++@value interface Type2 {+  refines Type1+}++@value interface Inherited<|#x> {}++@value interface Parent {+  refines Inherited<Type2>+}++concrete Child {+  refines Parent+  refines Inherited<Type1>+}
+ src/Test/testfiles/requires_concrete.0rx view
@@ -0,0 +1,3 @@+concrete Type<#x> {+  #x requires Type<#x>+}
+ src/Test/testfiles/resolved_in_preserved.0rx view
@@ -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)+}
+ src/Test/testfiles/successful_merge.0rx view
@@ -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<Type2>+  refines Interface2++  something (Type2) -> (Type2)+}++@value interface Test2 {+  refines Interface1<Type3>+  refines Test1++  something (Type2) -> (Type2)+}
+ src/Test/testfiles/successful_merge_params.0rx view
@@ -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)+}
+ src/Test/testfiles/type_duplicate_param.0rx view
@@ -0,0 +1,1 @@+@type interface Type<#x|#y|#x> {}
+ src/Test/testfiles/type_instances.0rx view
@@ -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<Value0>+}+++// Tests.++@type interface Object0<#x> {+  #x requires Value2 // -> Value0+  #x defines Type<#x>+  #x requires Value1<#x>+}++@type interface Object1<#x> {+  #x defines Type<Value0>+  #x requires Value3<#x>+}
+ src/Test/testfiles/type_interface.0rx view
@@ -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)+}
+ src/Test/testfiles/type_missing_define.0rx view
@@ -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<Value0>+}+++// Tests.++@type interface Object1<#x> {+  #x requires Value3<#x>+}
+ src/Test/testfiles/type_missing_refine.0rx view
@@ -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>+}
+ src/Test/testfiles/valid_filter_variance.0rx view
@@ -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>+}
+ src/Test/testfiles/valid_function_variance.0rx view
@@ -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>>) -> (Type1<#x>)+}++@type interface Type3<#x|> {+  // arg:    contravariant * contravariant * contravariant = contravariant+  // return: contravariant * contravariant = covariant+  something (Type1<Type1<#x>>) -> (Type1<#x>)+}
+ src/Test/testfiles/valid_variances.0rx view
@@ -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<Object1<#q>>+}++@type interface Object6<|#x> {}++concrete Object7<|#s> {+  // Variance reversed twice by Object1.+  defines Object6<Object1<Object1<#s>>>+}
+ src/Test/testfiles/value_cycle.0rx view
@@ -0,0 +1,11 @@+@value interface Type1 {+  refines Type2+}++@value interface Type2 {+  refines Type3+}++@value interface Type3 {+  refines Type1+}
+ src/Test/testfiles/value_duplicate_param.0rx view
@@ -0,0 +1,1 @@+@value interface Type<#x|#y|#x> {}
+ src/Test/testfiles/value_instances.0rx view
@@ -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<Value0>+}+++// Tests.++@value interface Object0<#x> {+  #x requires Value2 // -> Value0+  #x defines Type<#x>+  #x requires Value1<#x>+}++@value interface Object1<#x> {+  #x defines Type<Value0>+  #x requires Value3<#x>+}
+ src/Test/testfiles/value_interface.0rx view
@@ -0,0 +1,16 @@+@value interface Type<#a,#b|#c,#d|#e,#f> {+  refines Parent+  refines Other<Type2<#a>,#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)+}
+ src/Test/testfiles/value_missing_define.0rx view
@@ -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<Value0>+}+++// Tests.++@value interface Object1<#x> {+  #x requires Value3<#x>+}
+ src/Test/testfiles/value_missing_refine.0rx view
@@ -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>+}
+ src/Test/testfiles/value_refines_concrete.0rx view
@@ -0,0 +1,5 @@+concrete Parent {}++@value interface Child {+  refines Parent+}
+ src/Test/testfiles/value_refines_instance.0rx view
@@ -0,0 +1,5 @@+@type interface Parent {}++@value interface Child {+  refines Parent+}
+ src/Test/testfiles/value_refines_value.0rx view
@@ -0,0 +1,5 @@+@value interface Parent {}++@value interface Child {+  refines Parent+}
+ src/Test/testfiles/weak_arg.0rx view
@@ -0,0 +1,3 @@+@value interface Type {+  get () -> (weak Type)+}
+ src/Test/testfiles/weak_return.0rx view
@@ -0,0 +1,3 @@+@value interface Type {+  set (weak Type) -> ()+}
+ src/Types/Builtin.hs view
@@ -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 []
+ src/Types/DefinedCategory.hs view
@@ -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
+ src/Types/Function.hs view
@@ -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
+ src/Types/GeneralType.hs view
@@ -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
+ src/Types/IntegrationTest.hs view
@@ -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
+ src/Types/Positional.hs view
@@ -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
+ src/Types/Procedure.hs view
@@ -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)
+ src/Types/TypeCategory.hs view
@@ -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'
+ src/Types/TypeInstance.hs view
@@ -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')
+ src/Types/Variance.hs view
@@ -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
+ tests/.zeolite-module view
@@ -0,0 +1,1 @@+RecompileMetadata {rmRoot = "..", rmPath = "tests", rmPublicDeps = ["visibility","visibility2"], rmPrivateDeps = [], rmExtraFiles = [], rmExtraPaths = [], rmExtraRequires = [], rmMode = CompileIncremental, rmOutputName = ""}
+ tests/assignments.0rt view
@@ -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 () -> ()+}
+ tests/builtin-types.0rt view
@@ -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<Bool,Bool>(true))) {+      fail("Failed")+    }+    if (!present(reduce<Bool,AsBool>(true))) {+      fail("Failed")+    }+    if (present(reduce<Bool,AsChar>(true))) {+      fail("Failed")+    }+    if (!present(reduce<Bool,AsInt>(true))) {+      fail("Failed")+    }+    if (!present(reduce<Bool,AsFloat>(true))) {+      fail("Failed")+    }+    if (!present(reduce<Bool,Formatted>(true))) {+      fail("Failed")+    }+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "reduce Char" {+  success Test$run()+}++define Test {+  run () {+    if (!present(reduce<Char,Char>('a'))) {+      fail("Failed")+    }+    if (!present(reduce<Char,AsBool>('a'))) {+      fail("Failed")+    }+    if (!present(reduce<Char,AsChar>('a'))) {+      fail("Failed")+    }+    if (!present(reduce<Char,AsInt>('a'))) {+      fail("Failed")+    }+    if (!present(reduce<Char,AsFloat>('a'))) {+      fail("Failed")+    }+    if (!present(reduce<Char,Formatted>('a'))) {+      fail("Failed")+    }+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "reduce Int" {+  success Test$run()+}++define Test {+  run () {+    if (!present(reduce<Int,Int>(1))) {+      fail("Failed")+    }+    if (!present(reduce<Int,AsBool>(1))) {+      fail("Failed")+    }+    if (!present(reduce<Int,AsChar>(1))) {+      fail("Failed")+    }+    if (!present(reduce<Int,AsInt>(1))) {+      fail("Failed")+    }+    if (!present(reduce<Int,AsFloat>(1))) {+      fail("Failed")+    }+    if (!present(reduce<Int,Formatted>(1))) {+      fail("Failed")+    }+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "reduce Float" {+  success Test$run()+}++define Test {+  run () {+    if (!present(reduce<Float,Float>(1.0))) {+      fail("Failed")+    }+    if (!present(reduce<Float,AsBool>(1.0))) {+      fail("Failed")+    }+    if (present(reduce<Float,AsChar>(1.0))) {+      fail("Failed")+    }+    if (!present(reduce<Float,AsInt>(1.0))) {+      fail("Failed")+    }+    if (!present(reduce<Float,AsFloat>(1.0))) {+      fail("Failed")+    }+    if (!present(reduce<Float,Formatted>(1.0))) {+      fail("Failed")+    }+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "reduce String" {+  success Test$run()+}++define Test {+  run () {+    if (!present(reduce<String,String>("a"))) {+      fail("Failed")+    }+    if (!present(reduce<String,AsBool>("a"))) {+      fail("Failed")+    }+    if (present(reduce<String,AsChar>("a"))) {+      fail("Failed")+    }+    if (present(reduce<String,AsInt>("a"))) {+      fail("Failed")+    }+    if (present(reduce<String,AsFloat>("a"))) {+      fail("Failed")+    }+    if (!present(reduce<String,Formatted>("a"))) {+      fail("Failed")+    }+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "reduce ReadPosition success" {+  success Test$run()+}++define Test {+  run () {+    if (!present(reduce<ReadPosition<Char>,ReadPosition<Formatted>>("x"))) {+      fail("Failed")+    }+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "reduce ReadPosition fail" {+  success Test$run()+}++define Test {+  run () {+    if (present(reduce<ReadPosition<Formatted>,ReadPosition<Char>>("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 () -> ()+}
+ tests/conditionals.0rt view
@@ -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 () -> ()+}
+ tests/failure.0rt view
@@ -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 () -> ()+}
+ tests/filters.0rt view
@@ -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<Bool>()+  }+}++concrete Test {+  @type run () -> ()+}
+ tests/function-calls.0rt view
@@ -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<Value>()+  }+}++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>(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<Value<Test>>()+  }+}++concrete Test {+  @type run () -> ()+}
+ tests/function-merging.0rt view
@@ -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 () -> ()+}
+ tests/infix-functions.0rt view
@@ -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 () -> ()+}
+ tests/infix-operations.0rt view
@@ -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 () -> ()+}
+ tests/internal-inheritance.0rt view
@@ -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>++  @value Int value++  equals (x,y) {+    return x.get() == y.get()+  }++  create (x) {+    return Value{ x }+  }++  compare (x,y) {+    return Compare<Value>$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>++  @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<Value>$compare(value1,value2)) {+      fail("Failed")+    }+  }+}++concrete Test {+  @type run () -> ()+}
+ tests/internal-params.0rt view
@@ -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<Bool>()+  }+}++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<Bool>()+  }+}++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<Type1,Type2>()+  }+}++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<Bool>(Type<Bool>$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<String>(Type<Bool>$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<Formatted>()+    if (!value.check<String>("")) {+      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<Formatted>()+    if (value.check<Value>(value)) {+      fail("Failed")+    }+  }+}++concrete Test {+  @type run () -> ()+}
+ tests/member-init.0rt view
@@ -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 () -> ()+}
+ tests/modifed-storage.0rt view
@@ -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 () -> ()+}
+ tests/multiple-defs/.zeolite-module view
@@ -0,0 +1,1 @@+RecompileMetadata {rmRoot = "../..", rmPath = "tests/multiple-defs", rmPublicDeps = [], rmPrivateDeps = [], rmExtraFiles = [], rmExtraPaths = [], rmExtraRequires = [], rmMode = CompileIncremental, rmOutputName = ""}
+ tests/multiple-defs/README.md view
@@ -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)+```
+ tests/multiple-defs/private1.0rx view
@@ -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 {}
+ tests/multiple-defs/private2.0rx view
@@ -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 {}
+ tests/multiple-defs/public.0rp view
@@ -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 {}
+ tests/multiple-returns.0rt view
@@ -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 () -> ()+}
+ tests/named-returns.0rt view
@@ -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 () -> ()+}
+ tests/positional-returns.0rt view
@@ -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 () -> ()+}
+ tests/reduce.0rt view
@@ -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,Value>(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,Test>(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<Test,Value>(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,Test>(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<#x>,Value<#y>>(self)+  }+}++@value interface Type1 {}++@value interface Type2 {+  refines Type1+}++define Test {+  run () {+    Value<Type2> value <- Value<Type2>$create()+    scoped {+      optional Value<Type1> value2 <- value.attempt<Type1>()+    } 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<#x>,Value<#y>>(self)+  }+}++@value interface Type1 {}++@value interface Type2 {+  refines Type1+}++define Test {+  run () {+    Value<Type1> value <- Value<Type1>$create()+    scoped {+      optional Value<Type2> value2 <- value.attempt<Type2>()+    } 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<#x>,Value<#y>>(self)+  }+}++@value interface Type1 {}++@value interface Type2 {+  refines Type1+}++define Test {+  run () {+    Value<Value<Type2>> value <- Value<Value<Type2>>$create()+    scoped {+      optional Value<Value<Type1>> value2 <- value.attempt<Value<Type1>>()+    } 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<#x>,Value<#y>>(self)+  }+}++@value interface Type1 {}++@value interface Type2 {+  refines Type1+}++define Test {+  run () {+    Value<Value<Type1>> value <- Value<Value<Type1>>$create()+    scoped {+      optional Value<Value<Type2>> value2 <- value.attempt<Value<Type2>>()+    } 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,[Base1&Base2]>(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,[Base1&Base2]>(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<Test> value <- Value<Test>$create()+    scoped {+      optional Value<any> value2 <- reduce<Value<Test>,Value<any>>(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<Test> value <- Value<Test>$create()+    scoped {+      optional Value<all> value2 <- reduce<Value<Test>,Value<all>>(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<Test> value <- Value<Test>$create()+    scoped {+      optional Value<any> value2 <- reduce<Value<Test>,Value<any>>(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<all> value <- Value<all>$create()+    scoped {+      optional Value<Test> value2 <- reduce<Value<all>,Value<Test>>(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<any> value <- Value<any>$create()+    scoped {+      optional Value<Test> value2 <- reduce<Value<any>,Value<Test>>(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<all> value <- Value<all>$create()+    scoped {+      optional Value<Test> value2 <- reduce<Value<all>,Value<Test>>(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<Value<Test>,Formatted>(empty)+  }+}++concrete Test {+  @type run () -> ()+}
+ tests/scoped.0rt view
@@ -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 () -> ()+}
+ tests/simple.0rt view
@@ -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+}
+ tests/typename.0rt view
@@ -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<String>()+    if (name.formatted() != "String") {+      fail(name)+    }+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "Int typename" {+  success Test$run()+}++define Test {+  run () {+    Formatted name <- typename<Int>()+    if (name.formatted() != "Int") {+      fail(name)+    }+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "Char typename" {+  success Test$run()+}++define Test {+  run () {+    Formatted name <- typename<Char>()+    if (name.formatted() != "Char") {+      fail(name)+    }+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "Float typename" {+  success Test$run()+}++define Test {+  run () {+    Formatted name <- typename<Float>()+    if (name.formatted() != "Float") {+      fail(name)+    }+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "Bool typename" {+  success Test$run()+}++define Test {+  run () {+    Formatted name <- typename<Bool>()+    if (name.formatted() != "Bool") {+      fail(name)+    }+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "Formatted typename" {+  success Test$run()+}++define Test {+  run () {+    Formatted name <- typename<Formatted>()+    if (name.formatted() != "Formatted") {+      fail(name)+    }+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "ReadPosition typename" {+  success Test$run()+}++define Test {+  run () {+    Formatted name <- typename<ReadPosition<Char>>()+    if (name.formatted() != "ReadPosition<Char>") {+      fail(name)+    }+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "any typename" {+  success Test$run()+}++define Test {+  run () {+    Formatted name <- typename<any>()+    if (name.formatted() != "any") {+      fail(name)+    }+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "all typename" {+  success Test$run()+}++define Test {+  run () {+    Formatted name <- typename<all>()+    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<Type<#x,#y>>()+  }++  run () {+    Formatted name <- getTypename<String,Value<Int>>()+    if (name.formatted() != "Type<String,Value<Int>>") {+      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<Value<Test>>()+  }+}++concrete Test {+  @type run () -> ()+}
+ tests/unary-functions.0rt view
@@ -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 () -> ()+}
+ tests/unreachable.0rt view
@@ -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 () -> ()+}
+ tests/value-init.0rt view
@@ -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<Int> value <- Value<Int>$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<Int> value <- Value<String>$create<Int>(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<Int> value <- Value<Int>$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<Int> value <- Value<String>$create("x").create2<Int>(1)+    if (value.get() != 1) {+      fail("Failed")+    }+  }+}++concrete Test {+  @type run () -> ()+}
+ tests/visibility.0rt view
@@ -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 () -> ()+}
+ tests/visibility/.zeolite-module view
@@ -0,0 +1,1 @@+RecompileMetadata {rmRoot = "..", rmPath = "visibility", rmPublicDeps = [], rmPrivateDeps = ["internal"], rmExtraFiles = [], rmExtraPaths = [], rmExtraRequires = [], rmMode = CompileIncremental, rmOutputName = ""}
+ tests/visibility/getter.0rp view
@@ -0,0 +1,3 @@+concrete Getter {+  @type getValue () -> (Int)+}
+ tests/visibility/getter.0rx view
@@ -0,0 +1,5 @@+define Getter {+  getValue () {+    return Internal$create().get()+  }+}
+ tests/visibility/internal/.zeolite-module view
@@ -0,0 +1,1 @@+RecompileMetadata {rmRoot = "../..", rmPath = "visibility/internal", rmPublicDeps = [], rmPrivateDeps = [], rmExtraFiles = [], rmExtraPaths = [], rmExtraRequires = [], rmMode = CompileIncremental, rmOutputName = ""}
+ tests/visibility/internal/internal.0rp view
@@ -0,0 +1,4 @@+concrete Internal {+  @type create () -> (Internal)+  @value get () -> (Int)+}
+ tests/visibility/internal/internal.0rx view
@@ -0,0 +1,9 @@+define Internal {+  create () {+    return Internal{ }+  }++  get () {+    return 1+  }+}
+ tests/visibility2/.zeolite-module view
@@ -0,0 +1,1 @@+RecompileMetadata {rmRoot = "..", rmPath = "visibility2", rmPublicDeps = [], rmPrivateDeps = ["internal"], rmExtraFiles = [], rmExtraPaths = [], rmExtraRequires = [], rmMode = CompileIncremental, rmOutputName = ""}
+ tests/visibility2/getter2.0rp view
@@ -0,0 +1,3 @@+concrete Getter2 {+  @type getValue () -> (Int)+}
+ tests/visibility2/getter2.0rx view
@@ -0,0 +1,5 @@+define Getter2 {+  getValue () {+    return Internal$create().get()+  }+}
+ tests/visibility2/internal/.zeolite-module view
@@ -0,0 +1,1 @@+RecompileMetadata {rmRoot = "../..", rmPath = "visibility2/internal", rmPublicDeps = [], rmPrivateDeps = [], rmExtraFiles = [], rmExtraPaths = [], rmExtraRequires = [], rmMode = CompileIncremental, rmOutputName = ""}
+ tests/visibility2/internal/internal.0rp view
@@ -0,0 +1,4 @@+concrete Internal {+  @type create () -> (Internal)+  @value get () -> (Int)+}
+ tests/visibility2/internal/internal.0rx view
@@ -0,0 +1,9 @@+define Internal {+  create () {+    return Internal{ }+  }++  get () {+    return 2+  }+}
+ tests/while.0rt view
@@ -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 () -> ()+}
+ zeolite-lang.cabal view
@@ -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+  <https://github.com/ta0kira/zeolite Zeolite on GitHub> 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+    <https://github.com/ta0kira/zeolite/issues issue on GitHub> if you encounter+    any errors.+    .+    @+    ZEOLITE_PATH=$(zeolite --get-path)+    zeolite -p "$ZEOLITE_PATH" -t tests lib\/file lib\/util+    @+  .+  The <https://github.com/ta0kira/zeolite/tree/master/example code examples> 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 <ta0kira@gmail.com>+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