diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,71 @@ # Revision history for zeolite-lang +## 0.9.0.0 -- 2020-11-23 + +### Compiler CLI + +* **[breaking]** Major changes to C++ extensions: + + * **[breaking]** Corrects hole in `$ModuleOnly$` visibility in C++ extensions. + Previously, C++ extensions could directly access categories defined in + `$ModuleOnly$` sources in dependencies. + + * **[breaking]** Randomizes cache paths and `namespace`s for generated C++ + code so that C++ extensions cannot use static `#include` paths to circumvent + the visibility rules of a dependency. + + * **[breaking]** Makes `TypeInstance`s shared in generated C++ and in C++ + extensions, to allow for better memory management of `@type`s in the future. + + * **[breaking]** Adds guards to C++ headers for `$TestsOnly$` categories, to + prevent them from being used in non-`$TestsOnly$` C++ extensions. + +* **[fix]** Fixes regression where calling `zeolite` with `-p` would overwrite + an existing `.zeolite-module`. + +### Language + +* **[breaking]** Syntax changes: + + * **[breaking]** Changes the syntax for calling `@category` functions from + `$$` to `:`, e.g., `Foo:create()` instead of `Foo$$create()`. A new error + message (to be removed later) will remind the user to stop using `$$`. + + * **[breaking]** Changes the syntax for calling `@type` functions from `$` + to `.`, e.g., `Foo.create()` instead of `Foo$create()`. A new error message + (to be removed later) will remind the user to stop using `$`. + +* **[breaking]** Changes to param usage: + + * **[breaking]** Updates param inference to be more accurate. The new + algorithm will infer a param type iff the best choice is unambiguous given + the expected and actual function arguments. + + * **[breaking]** Disallows bounding a single param both above and below, e.g., + having both `#x requires Foo` and `#x allows Bar`. This is primarily to + prevent cycles and contradictions in the type system. + + Previously, the *best case* for such restrictions was that there are + extremely few choices for `#x`, and the *worst case* was that it implies + `Bar` converts to `Foo` when it isn't true, thus making `#x` unusable. + Having either of those requirements likely indicates a design flaw. + +* **[breaking]** Prohibits having a `$TestsOnly$` definition for a + non-`$TestsOnly$` category. Previously, a `concrete` category declared in a + non-`$TestsOnly$` `.0rp` could be `define`d in a `$TestsOnly$` `.0rx`, which + creates a loophole that allows binaries to utilize `$TestsOnly$` code. + +* **[fix]** Fixes a latent type-checking bug that could occur when attempting to + assign a value with an intersection type to a variable with a union type, if + one or both types has another nested type, e.g., `[A&B]`→`[[A&B]|C]` or + `[[A|B]&C]`→`[A|B]`. This change *shouldn't* cause new type-checking failures. + +### Libraries + +* **[fix]** Implements `subSequence` for `Argv` in `lib/util`. This is required + by `ReadPosition` but was forgotten. Calling it prior to this would cause a + failure. + ## 0.8.0.0 -- 2020-08-07 ### Language diff --git a/base/Category_Bool.cpp b/base/Category_Bool.cpp --- a/base/Category_Bool.cpp +++ b/base/Category_Bool.cpp @@ -29,9 +29,9 @@ #include "Category_Equals.hpp" -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -namespace ZEOLITE_DYNAMIC_NAMESPACE { -#endif // ZEOLITE_DYNAMIC_NAMESPACE +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE namespace { const int collection_Bool = 0; } // namespace @@ -39,7 +39,6 @@ namespace { class Category_Bool; class Type_Bool; -Type_Bool& CreateType_Bool(Params<0>::Type params); class Value_Bool; S CreateValue(Type_Bool& parent, const ParamTuple& params, const ValueTuple& args); struct Category_Bool : public TypeCategory { @@ -64,33 +63,33 @@ return TypeInstance::TypeNameFrom(output, parent); } Category_Bool& parent; - bool CanConvertFrom(const TypeInstance& from) const final { - std::vector args; - if (!from.TypeArgsForParent(parent, args)) return false; + bool CanConvertFrom(const S& from) const final { + std::vector> args; + if (!from->TypeArgsForParent(parent, args)) return false; if(args.size() != 0) { FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); } return true; } - bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { if (&category == &GetCategory_Bool()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_AsBool()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_AsInt()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_AsFloat()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_Formatted()) { - args = std::vector{}; + args = std::vector>{}; return true; } return false; @@ -100,7 +99,8 @@ CycleCheck marker(*this); TRACE_FUNCTION("Bool (init @type)") } - ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + ReturnTuple Dispatch(const S& self, 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, @@ -111,16 +111,16 @@ } return (this->*Table_Equals[label.function_num])(params, args); } - return TypeInstance::Dispatch(label, params, args); + return TypeInstance::Dispatch(self, label, params, args); } ReturnTuple Call_equals(const ParamTuple& params, const ValueTuple& args); }; -Type_Bool& CreateType_Bool(Params<0>::Type params) { - static auto& cached = *new Type_Bool(CreateCategory_Bool(), Params<0>::Type()); +S CreateType_Bool(Params<0>::Type params) { + static const auto cached = S_get(new Type_Bool(CreateCategory_Bool(), Params<0>::Type())); return cached; } struct Value_Bool : public TypeValue { - Value_Bool(Type_Bool& p, bool value) : parent(p), value_(value) {} + Value_Bool(S p, bool value) : parent(p), value_(value) {} ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { using CallType = ReturnTuple(Value_Bool::*)(const S&, const ParamTuple&, const ValueTuple&); static const CallType Table_AsBool[] = { @@ -161,13 +161,13 @@ } return TypeValue::Dispatch(self, label, params, args); } - std::string CategoryName() const final { return parent.CategoryName(); } + std::string CategoryName() const final { return parent->CategoryName(); } bool AsBool() const final { return value_; } ReturnTuple Call_asBool(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_asFloat(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_asInt(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_formatted(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - Type_Bool& parent; + const S parent; const bool value_; }; ReturnTuple Type_Bool::Call_equals(const ParamTuple& params, const ValueTuple& args) { @@ -198,13 +198,13 @@ TypeCategory& GetCategory_Bool() { return CreateCategory_Bool(); } -TypeInstance& GetType_Bool(Params<0>::Type params) { +S 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 +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE S Box_Bool(bool value) { diff --git a/base/Category_Char.cpp b/base/Category_Char.cpp --- a/base/Category_Char.cpp +++ b/base/Category_Char.cpp @@ -31,9 +31,9 @@ #include "Category_LessThan.hpp" -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -namespace ZEOLITE_DYNAMIC_NAMESPACE { -#endif // ZEOLITE_DYNAMIC_NAMESPACE +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE namespace { const int collection_Char = 0; } // namespace @@ -41,7 +41,6 @@ namespace { class Category_Char; class Type_Char; -Type_Char& CreateType_Char(Params<0>::Type params); class Value_Char; S CreateValue(Type_Char& parent, const ParamTuple& params, const ValueTuple& args); struct Category_Char : public TypeCategory { @@ -66,37 +65,37 @@ return TypeInstance::TypeNameFrom(output, parent); } Category_Char& parent; - bool CanConvertFrom(const TypeInstance& from) const final { - std::vector args; - if (!from.TypeArgsForParent(parent, args)) return false; + bool CanConvertFrom(const S& from) const final { + std::vector> args; + if (!from->TypeArgsForParent(parent, args)) return false; if(args.size() != 0) { FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); } return true; } - bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { if (&category == &GetCategory_Char()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_AsBool()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_AsChar()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_AsInt()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_AsFloat()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_Formatted()) { - args = std::vector{}; + args = std::vector>{}; return true; } return false; @@ -106,7 +105,8 @@ CycleCheck marker(*this); TRACE_FUNCTION("Char (init @type)") } - ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + ReturnTuple Dispatch(const S& self, 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, @@ -126,17 +126,17 @@ } return (this->*Table_LessThan[label.function_num])(params, args); } - return TypeInstance::Dispatch(label, params, args); + return TypeInstance::Dispatch(self, 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& cached = *new Type_Char(CreateCategory_Char(), Params<0>::Type()); +S CreateType_Char(Params<0>::Type params) { + static const auto cached = S_get(new Type_Char(CreateCategory_Char(), Params<0>::Type())); return cached; } struct Value_Char : public TypeValue { - Value_Char(Type_Char& p, PrimChar value) : parent(p), value_(value) {} + Value_Char(S p, PrimChar value) : parent(p), value_(value) {} ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { using CallType = ReturnTuple(Value_Char::*)(const S&, const ParamTuple&, const ValueTuple&); static const CallType Table_AsBool[] = { @@ -186,14 +186,14 @@ } return TypeValue::Dispatch(self, label, params, args); } - std::string CategoryName() const final { return parent.CategoryName(); } + std::string CategoryName() const final { return parent->CategoryName(); } PrimChar AsChar() const final { return value_; } ReturnTuple Call_asBool(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_asChar(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_asFloat(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_asInt(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_formatted(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - Type_Char& parent; + const S parent; const PrimChar value_; }; ReturnTuple Type_Char::Call_equals(const ParamTuple& params, const ValueTuple& args) { @@ -234,13 +234,13 @@ TypeCategory& GetCategory_Char() { return CreateCategory_Char(); } -TypeInstance& GetType_Char(Params<0>::Type params) { +S 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 +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE S Box_Char(PrimChar value) { diff --git a/base/Category_Float.cpp b/base/Category_Float.cpp --- a/base/Category_Float.cpp +++ b/base/Category_Float.cpp @@ -30,9 +30,9 @@ #include "Category_LessThan.hpp" -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -namespace ZEOLITE_DYNAMIC_NAMESPACE { -#endif // ZEOLITE_DYNAMIC_NAMESPACE +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE namespace { const int collection_Float = 0; } // namespace @@ -40,7 +40,6 @@ namespace { class Category_Float; class Type_Float; -Type_Float& CreateType_Float(Params<0>::Type params); class Value_Float; S CreateValue(Type_Float& parent, const ParamTuple& params, const ValueTuple& args); struct Category_Float : public TypeCategory { @@ -65,33 +64,33 @@ return TypeInstance::TypeNameFrom(output, parent); } Category_Float& parent; - bool CanConvertFrom(const TypeInstance& from) const final { - std::vector args; - if (!from.TypeArgsForParent(parent, args)) return false; + bool CanConvertFrom(const S& from) const final { + std::vector> args; + if (!from->TypeArgsForParent(parent, args)) return false; if(args.size() != 0) { FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); } return true; } - bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { if (&category == &GetCategory_Float()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_AsBool()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_AsInt()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_AsFloat()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_Formatted()) { - args = std::vector{}; + args = std::vector>{}; return true; } return false; @@ -101,7 +100,8 @@ CycleCheck marker(*this); TRACE_FUNCTION("Float (init @type)") } - ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + ReturnTuple Dispatch(const S& self, 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, @@ -121,17 +121,17 @@ } return (this->*Table_LessThan[label.function_num])(params, args); } - return TypeInstance::Dispatch(label, params, args); + return TypeInstance::Dispatch(self, 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& cached = *new Type_Float(CreateCategory_Float(), Params<0>::Type()); +S CreateType_Float(Params<0>::Type params) { + static const auto cached = S_get(new Type_Float(CreateCategory_Float(), Params<0>::Type())); return cached; } struct Value_Float : public TypeValue { - Value_Float(Type_Float& p, PrimFloat value) : parent(p), value_(value) {} + Value_Float(S p, PrimFloat value) : parent(p), value_(value) {} ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { using CallType = ReturnTuple(Value_Float::*)(const S&, const ParamTuple&, const ValueTuple&); static const CallType Table_AsBool[] = { @@ -172,13 +172,13 @@ } return TypeValue::Dispatch(self, label, params, args); } - std::string CategoryName() const final { return parent.CategoryName(); } + std::string CategoryName() const final { return parent->CategoryName(); } PrimFloat AsFloat() const final { return value_; } ReturnTuple Call_asBool(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_asFloat(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_asInt(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_formatted(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - Type_Float& parent; + const S parent; const PrimFloat value_; }; ReturnTuple Type_Float::Call_equals(const ParamTuple& params, const ValueTuple& args) { @@ -215,13 +215,13 @@ TypeCategory& GetCategory_Float() { return CreateCategory_Float(); } -TypeInstance& GetType_Float(Params<0>::Type params) { +S 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 +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE S Box_Float(PrimFloat value) { diff --git a/base/Category_Int.cpp b/base/Category_Int.cpp --- a/base/Category_Int.cpp +++ b/base/Category_Int.cpp @@ -31,9 +31,9 @@ #include "Category_LessThan.hpp" -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -namespace ZEOLITE_DYNAMIC_NAMESPACE { -#endif // ZEOLITE_DYNAMIC_NAMESPACE +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE namespace { const int collection_Int = 0; } // namespace @@ -41,7 +41,6 @@ namespace { class Category_Int; class Type_Int; -Type_Int& CreateType_Int(Params<0>::Type params); class Value_Int; S CreateValue(Type_Int& parent, const ParamTuple& params, const ValueTuple& args); struct Category_Int : public TypeCategory { @@ -66,37 +65,37 @@ return TypeInstance::TypeNameFrom(output, parent); } Category_Int& parent; - bool CanConvertFrom(const TypeInstance& from) const final { - std::vector args; - if (!from.TypeArgsForParent(parent, args)) return false; + bool CanConvertFrom(const S& from) const final { + std::vector> args; + if (!from->TypeArgsForParent(parent, args)) return false; if(args.size() != 0) { FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); } return true; } - bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { if (&category == &GetCategory_Int()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_AsBool()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_AsChar()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_AsInt()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_AsFloat()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_Formatted()) { - args = std::vector{}; + args = std::vector>{}; return true; } return false; @@ -106,7 +105,8 @@ CycleCheck marker(*this); TRACE_FUNCTION("Int (init @type)") } - ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + ReturnTuple Dispatch(const S& self, 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, @@ -126,17 +126,17 @@ } return (this->*Table_LessThan[label.function_num])(params, args); } - return TypeInstance::Dispatch(label, params, args); + return TypeInstance::Dispatch(self, 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& cached = *new Type_Int(CreateCategory_Int(), Params<0>::Type()); +S CreateType_Int(Params<0>::Type params) { + static const auto cached = S_get(new Type_Int(CreateCategory_Int(), Params<0>::Type())); return cached; } struct Value_Int : public TypeValue { - Value_Int(Type_Int& p, PrimInt value) : parent(p), value_(value) {} + Value_Int(S p, PrimInt value) : parent(p), value_(value) {} ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { using CallType = ReturnTuple(Value_Int::*)(const S&, const ParamTuple&, const ValueTuple&); static const CallType Table_AsBool[] = { @@ -186,14 +186,14 @@ } return TypeValue::Dispatch(self, label, params, args); } - std::string CategoryName() const final { return parent.CategoryName(); } + std::string CategoryName() const final { return parent->CategoryName(); } PrimInt AsInt() const final { return value_; } ReturnTuple Call_asBool(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_asChar(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_asFloat(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_asInt(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_formatted(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - Type_Int& parent; + const S parent; const PrimInt value_; }; ReturnTuple Type_Int::Call_equals(const ParamTuple& params, const ValueTuple& args) { @@ -234,13 +234,13 @@ TypeCategory& GetCategory_Int() { return CreateCategory_Int(); } -TypeInstance& GetType_Int(Params<0>::Type params) { +S 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 +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE S Box_Int(PrimInt value) { diff --git a/base/Category_String.cpp b/base/Category_String.cpp --- a/base/Category_String.cpp +++ b/base/Category_String.cpp @@ -31,9 +31,9 @@ #include "Category_Builder.hpp" -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -namespace ZEOLITE_DYNAMIC_NAMESPACE { -#endif // ZEOLITE_DYNAMIC_NAMESPACE +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE namespace { const int collection_String = 0; } // namespace @@ -43,7 +43,6 @@ namespace { class Category_String; class Type_String; -Type_String& CreateType_String(Params<0>::Type params); class Value_String; S CreateValue(Type_String& parent, const ParamTuple& params, const ValueTuple& args); struct Category_String : public TypeCategory { @@ -68,29 +67,29 @@ return TypeInstance::TypeNameFrom(output, parent); } Category_String& parent; - bool CanConvertFrom(const TypeInstance& from) const final { - std::vector args; - if (!from.TypeArgsForParent(parent, args)) return false; + bool CanConvertFrom(const S& from) const final { + std::vector> args; + if (!from->TypeArgsForParent(parent, args)) return false; if(args.size() != 0) { FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); } return true; } - bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { if (&category == &GetCategory_String()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_AsBool()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_Formatted()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_ReadPosition()) { - args = std::vector{&GetType_Char(T_get())}; + args = std::vector>{GetType_Char(T_get())}; return true; } return false; @@ -100,7 +99,8 @@ CycleCheck marker(*this); TRACE_FUNCTION("String (init @type)") } - ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + ReturnTuple Dispatch(const S& self, 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, @@ -129,18 +129,18 @@ } return (this->*Table_String[label.function_num])(params, args); } - return TypeInstance::Dispatch(label, params, args); + return TypeInstance::Dispatch(self, label, params, args); } ReturnTuple Call_builder(const ParamTuple& params, const ValueTuple& 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& cached = *new Type_String(CreateCategory_String(), Params<0>::Type()); +S CreateType_String(Params<0>::Type params) { + static const auto cached = S_get(new Type_String(CreateCategory_String(), Params<0>::Type())); return cached; } struct Value_String : public TypeValue { - Value_String(Type_String& p, const PrimString& value) : parent(p), value_(value) {} + Value_String(S p, const PrimString& value) : parent(p), value_(value) {} ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { using CallType = ReturnTuple(Value_String::*)(const S&, const ParamTuple&, const ValueTuple&); static const CallType Table_AsBool[] = { @@ -183,14 +183,14 @@ } return TypeValue::Dispatch(self, label, params, args); } - std::string CategoryName() const final { return parent.CategoryName(); } + std::string CategoryName() const final { return parent->CategoryName(); } const PrimString& AsString() const final { return value_; } ReturnTuple Call_asBool(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_formatted(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_readPosition(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_readSize(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_subSequence(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - Type_String& parent; + const S parent; const PrimString value_; }; @@ -278,13 +278,13 @@ TypeCategory& GetCategory_String() { return CreateCategory_String(); } -TypeInstance& GetType_String(Params<0>::Type params) { +S 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 +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE S Box_String(const PrimString& value) { diff --git a/base/category-header.hpp b/base/category-header.hpp --- a/base/category-header.hpp +++ b/base/category-header.hpp @@ -31,12 +31,8 @@ class TypeFunction; class ValueFunction; -TypeInstance& Merge_Intersect(L params); -TypeInstance& Merge_Union(L params); - -TypeInstance& GetMerged_Any(); -TypeInstance& GetMerged_All(); - -extern const S& Var_empty; +#if defined(ZEOLITE_PUBLIC_NAMESPACE) && !defined(ZEOLITE_DYNAMIC_NAMESPACE) +#define ZEOLITE_DYNAMIC_NAMESPACE ZEOLITE_PUBLIC_NAMESPACE +#endif #endif // CATEGORY_HEADER_HPP_ diff --git a/base/category-source.cpp b/base/category-source.cpp --- a/base/category-source.cpp +++ b/base/category-source.cpp @@ -18,6 +18,8 @@ #include "category-source.hpp" +#include + #include "logging.hpp" @@ -37,7 +39,7 @@ }; struct Type_Intersect : public TypeInstance { - Type_Intersect(L params) : params_(params.begin(), params.end()) {} + Type_Intersect(L> params) : params_(params.begin(), params.end()) {} std::string CategoryName() const final { return "(intersection)"; } @@ -59,14 +61,14 @@ MergeType InstanceMergeType() const final { return MergeType::INTERSECT; } - std::vector MergedTypes() const final + std::vector> MergedTypes() const final { return params_; } - const L params_; + const L> params_; }; struct Type_Union : public TypeInstance { - Type_Union(L params) : params_(params.begin(), params.end()) {} + Type_Union(L> params) : params_(params.begin(), params.end()) {} std::string CategoryName() const final { return "(union)"; } @@ -88,36 +90,47 @@ MergeType InstanceMergeType() const final { return MergeType::UNION; } - std::vector MergedTypes() const final + std::vector> MergedTypes() const final { return params_; } - const L params_; + const L> params_; }; +L ParamsToKey(const L>& params) { + L key; + for (const auto& param : params) { + key.push_back(param.get()); + } + std::sort(key.begin(), key.end()); + return key; +} + } // namespace -TypeInstance& Merge_Intersect(L params) { - static auto& cache = *new std::map,R>(); - auto& cached = cache[params]; - if (!cached) { cached = R_get(new Type_Intersect(params)); } - return *cached; +S Merge_Intersect(L> params) { + static auto& cache = *new std::map,S>(); + auto& cached = cache[ParamsToKey(params)]; + S type = cached; + if (!type) { cached = type = S_get(new Type_Intersect(params)); } + return type; } -TypeInstance& Merge_Union(L params) { - static auto& cache = *new std::map,R>(); - auto& cached = cache[params]; - if (!cached) { cached = R_get(new Type_Union(params)); } - return *cached; +S Merge_Union(L> params) { + static auto& cache = *new std::map,S>(); + auto& cached = cache[ParamsToKey(params)]; + S type = cached; + if (!type) { cached = type = S_get(new Type_Union(params)); } + return type; } -TypeInstance& GetMerged_Any() { - static auto& instance = Merge_Intersect(L_get()); +const S& GetMerged_Any() { + static const auto instance = Merge_Intersect(L_get>()); return instance; } -TypeInstance& GetMerged_All() { - static auto& instance = Merge_Union(L_get()); +const S& GetMerged_All() { + static const auto instance = Merge_Union(L_get>()); return instance; } @@ -131,77 +144,53 @@ __builtin_unreachable(); } -ReturnTuple TypeInstance::Dispatch(const TypeFunction& label, +ReturnTuple TypeInstance::Dispatch(const S& self, const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) { FAIL() << CategoryName() << " does not implement " << label; __builtin_unreachable(); } -ReturnTuple TypeValue::Dispatch(const S& self, - const ValueFunction& label, +ReturnTuple TypeValue::Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params, const ValueTuple& args) { FAIL() << CategoryName() << " does not implement " << label; __builtin_unreachable(); } -bool TypeInstance::CanConvert(const TypeInstance& x, const TypeInstance& y) { - if (&x == &y) { +bool TypeInstance::CanConvert(const S& x, + const S& y) { + // See checkGeneralType for the ordering here. + if (x.get() == y.get()) { 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; + } else if (y->InstanceMergeType() == MergeType::INTERSECT) { + for (const auto& right : y->MergedTypes()) { + if (!TypeInstance::CanConvert(x, right)) { + return false; + } } - } - 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; + return true; + } else if (x->InstanceMergeType() == MergeType::UNION) { + for (const auto& left : x->MergedTypes()) { + if (!TypeInstance::CanConvert(left, y)) { + return false; + } } - } - switch (y.InstanceMergeType()) { - case MergeType::SINGLE: return false; - case MergeType::UNION: return false; - case MergeType::INTERSECT: return true; + return true; + } else if (x->InstanceMergeType() == MergeType::INTERSECT) { + for (const auto& left : x->MergedTypes()) { + if (TypeInstance::CanConvert(left, y)) { + return true; + } + } + return false; + } else if (y->InstanceMergeType() == MergeType::UNION) { + for (const auto right : y->MergedTypes()) { + if (TypeInstance::CanConvert(x, right)) { + return true; + } + } + return false; + } else { + return y->CanConvertFrom(x); } } diff --git a/base/category-source.hpp b/base/category-source.hpp --- a/base/category-source.hpp +++ b/base/category-source.hpp @@ -19,6 +19,7 @@ #ifndef CATEGORY_SOURCE_HPP_ #define CATEGORY_SOURCE_HPP_ +#include // For occasional debugging output in generated code. #include #include #include @@ -43,7 +44,15 @@ S Box_Int(PrimInt value); S Box_Float(PrimFloat value); +S Merge_Intersect(L> params); +S Merge_Union(L> params); +const S& GetMerged_Any(); +const S& GetMerged_All(); + +extern const S& Var_empty; + + class TypeCategory { public: inline ReturnTuple Call(const CategoryFunction& label, @@ -65,28 +74,34 @@ class TypeInstance { public: - inline ReturnTuple Call(const TypeFunction& label, - ParamTuple params, const ValueTuple& args) { - return Dispatch(label, params, args); + inline static ReturnTuple Call(const S& target, + const TypeFunction& label, + 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; virtual void BuildTypeName(std::ostream& output) const = 0; - static std::string TypeName(const TypeInstance& type) { + static std::string TypeName(const S& type) { + TRACE_FUNCTION("typename") std::ostringstream output; - type.BuildTypeName(output); + type->BuildTypeName(output); return output.str(); } - static S Reduce(TypeInstance& from, TypeInstance& to, S target) { + static S Reduce(const S& from, + const S& to, S target) { TRACE_FUNCTION("reduce") return CanConvert(from, to)? target : Var_empty; } virtual bool TypeArgsForParent( - const TypeCategory& category, std::vector& args) const + const TypeCategory& category, std::vector>& args) const { return false; } ALWAYS_PERMANENT(TypeInstance) @@ -95,18 +110,18 @@ protected: TypeInstance() = default; - virtual ReturnTuple Dispatch(const TypeFunction& label, + virtual ReturnTuple Dispatch(const S& self, const TypeFunction& label, const ParamTuple& params, const ValueTuple& args); - virtual bool CanConvertFrom(const TypeInstance& from) const + virtual bool CanConvertFrom(const S& from) const { return false; } - static bool CanConvert(const TypeInstance& from, const TypeInstance& to); + static bool CanConvert(const S& from, const S& to); template static void TypeNameFrom(std::ostream& output, const TypeCategory& category, const Ts&... params) { - std::vector params2{¶ms...}; + std::vector params2{params.get()...}; output << category.CategoryName(); if (!params2.empty()) { output << "<"; @@ -130,11 +145,10 @@ virtual MergeType InstanceMergeType() const { return MergeType::SINGLE; } - virtual std::vector MergedTypes() const - { return std::vector{this}; } - - static bool ExpandCheckLeft(const TypeInstance& from, const TypeInstance& to); - static bool ExpandCheckRight(const TypeInstance& from, const TypeInstance& to); + virtual std::vector> MergedTypes() const { + FAIL() << "Category " << CategoryName() << " is not a merged type"; + __builtin_unreachable(); + } }; class TypeValue { @@ -169,12 +183,11 @@ virtual bool Present() const; - virtual ReturnTuple Dispatch(const S& self, - const ValueFunction& label, + virtual ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params, const ValueTuple& args); }; template -using InstanceMap = std::map::Type, R>; +using WeakInstanceMap = std::map::Type, S>; #endif // CATEGORY_SOURCE_HPP_ diff --git a/base/types.cpp b/base/types.cpp --- a/base/types.cpp +++ b/base/types.cpp @@ -79,7 +79,7 @@ return params_.size(); } -TypeInstance* ParamTuple::At(int pos) const { +const S& ParamTuple::At(int pos) const { if (pos < 0 || pos >= params_.size()) { FAIL() << "Bad ParamTuple index"; } diff --git a/base/types.hpp b/base/types.hpp --- a/base/types.hpp +++ b/base/types.hpp @@ -121,7 +121,7 @@ template struct Params { - using Type = typename Params::Type; + using Type = typename Params&, Ts...>::Type; }; template @@ -129,7 +129,35 @@ using Type = T; }; +template +struct ParamsKey { + using Type = typename ParamsKey::Type; +}; +template +struct ParamsKey<0, Ts...> { + using Type = T; +}; + +template +struct KeyFromParams { + static typename ParamsKey::Type Get(const typename Params::Type& from, Ts... args) { + return KeyFromParams::Get(from, args..., std::get(from).get()); + } +}; + +template +struct KeyFromParams { + static typename ParamsKey::Type Get(const typename Params::Type&, Ts... args) { + return typename ParamsKey::Type(args...); + } +}; + +template +typename ParamsKey::Type GetKeyFromParams(const typename Params::Type& from) { + return KeyFromParams::Get(from); +} + class ValueTuple { public: virtual int Size() const = 0; @@ -189,17 +217,17 @@ ParamTuple(ParamTuple&& other) : params_(std::move(other.params_)) {} template - explicit ParamTuple(Ts*... args) : params_{args...} {} + explicit ParamTuple(const Ts&... args) : params_{args...} {} int Size() const; - TypeInstance* At(int pos) const; + const S& At(int pos) const; private: ParamTuple(const ParamTuple&) = delete; ParamTuple& operator =(const ParamTuple&) = delete; void* operator new(std::size_t size) = delete; - std::vector params_; + std::vector> params_; }; #endif // TYPES_HPP_ diff --git a/bin/unit-tests.hs b/bin/unit-tests.hs --- a/bin/unit-tests.hs +++ b/bin/unit-tests.hs @@ -48,4 +48,4 @@ ] labelWith :: String -> [IO (CompileInfo ())] -> [IO (CompileInfo ())] -labelWith s ts = map (\(n,t) -> fmap (`reviseErrorM` ("In " ++ s ++ " (#" ++ show n ++ "):")) t) (zip ([1..] :: [Int]) ts) +labelWith s ts = map (\(n,t) -> fmap (> exitFailure @@ -74,12 +74,14 @@ then exitSuccess else exitFailure tryFastModes ("--show-deps":ps) = do - tryCompileInfoIO "Zeolite execution failed." $ mapM_ showDeps ps + tryZeoliteIO $ do + (_,backend) <- loadConfig + let h = getCompilerHash backend + mapM_ (showDeps h) ps exitSuccess where - showDeps p = do - (_,backend) <- loadConfig + showDeps h p = do p' <- errorFromIO $ canonicalizePath p - m <- loadModuleMetadata (getCompilerHash backend) ForceAll Map.empty p' + m <- loadModuleMetadata h ForceAll Map.empty p' errorFromIO $ hPutStrLn stdout $ show p' errorFromIO $ mapM_ showDep (cmObjectFiles m) showDep (CategoryObjectFile c ds _) = do @@ -88,3 +90,6 @@ " " ++ show (ciPath d)) ds showDep _ = return () tryFastModes _ = return () + +tryZeoliteIO :: CompileInfoIO a -> IO a +tryZeoliteIO = tryCompileInfoIO "Warnings (ignored):" "Zeolite execution failed:" diff --git a/example/hello/hello-demo.0rx b/example/hello/hello-demo.0rx --- a/example/hello/hello-demo.0rx +++ b/example/hello/hello-demo.0rx @@ -5,24 +5,24 @@ define HelloDemo { run () { scoped { - TextReader reader <- TextReader$fromBlockReader(SimpleInput$stdin()) + TextReader reader <- TextReader.fromBlockReader(SimpleInput.stdin()) } cleanup { - \ LazyStream$new() + \ LazyStream.new() .append("Goodbye.\n") - .writeTo(SimpleOutput$stderr()) + .writeTo(SimpleOutput.stderr()) } in while (!reader.pastEnd()) { - \ LazyStream$new() + \ LazyStream.new() .append("What is your name? ") - .writeTo(SimpleOutput$stderr()) + .writeTo(SimpleOutput.stderr()) String name <- reader.readNextLine() if (name.readSize() == 0) { break } - \ LazyStream$new() + \ LazyStream.new() .append("Hello \"") .append(name) .append("\", if that's your real name.\n") - .writeTo(SimpleOutput$stderr()) + .writeTo(SimpleOutput.stderr()) } } } diff --git a/example/parser/README.md b/example/parser/README.md --- a/example/parser/README.md +++ b/example/parser/README.md @@ -53,7 +53,7 @@ require special instructions, scripting, or `Makefile`s. - **Type Inference.** Several of the function definitions in the `.0rx` files - request parameter type-inference using `?`, e.g., `ErrorOr$$value(match)`. + request parameter type-inference using `?`, e.g., `ErrorOr:value(match)`. This is useful when the parameter value can be easily guessed by the reader of the code from its context. diff --git a/example/parser/parse-text.0rx b/example/parser/parse-text.0rx --- a/example/parser/parse-text.0rx +++ b/example/parser/parse-text.0rx @@ -17,14 +17,14 @@ // Partial match => set error context. return context.setBrokenInput(message) } else { - return context.setValue(ErrorOr$$error(message)) + return context.setValue(ErrorOr:error(message)) } } } update { index <- index+1 context <- context.advance() } - return context.setValue(ErrorOr$$value(match)) + return context.setValue(ErrorOr:value(match)) } create (match) { @@ -47,7 +47,7 @@ min.formatted() + "," + max.formatted() + "} at " + contextOld.getPosition() ParseContext context <- contextOld - Builder builder <- String$builder() + Builder builder <- String.builder() Int count <- 0 while (!context.atEof() && (max == 0 || count < max)) { Bool found <- false @@ -70,12 +70,12 @@ context <- context.advance() } if (count >= min) { - return context.setValue(ErrorOr$$value(builder.build())) + return context.setValue(ErrorOr:value(builder.build())) } elif (count > 0) { // Partial match => set error context. return context.setBrokenInput(message) } else { - return context.setValue(ErrorOr$$error(message)) + return context.setValue(ErrorOr:error(message)) } } @@ -95,9 +95,9 @@ } if (contextOld.atEof() || contextOld.current() != match) { String message <- "Failed to match '" + match.formatted() + "' at " + contextOld.getPosition() - return contextOld.setValue(ErrorOr$$error(message)) + return contextOld.setValue(ErrorOr:error(message)) } else { - return contextOld.advance().setValue(ErrorOr$$value(match)) + return contextOld.advance().setValue(ErrorOr:value(match)) } } @@ -116,7 +116,7 @@ @value #x value run (contextOld) { - return contextOld.setValue(ErrorOr$$value(value)) + return contextOld.setValue(ErrorOr:value(value)) } create (value) { @@ -134,7 +134,7 @@ @value Formatted message run (contextOld) { - return contextOld.setValue(ErrorOr$$error(message)) + return contextOld.setValue(ErrorOr:error(message)) } create (message) { @@ -157,7 +157,7 @@ } ParseContext<#x> context <- contextOld.run<#x>(parser) if (context.hasAnyError()) { - return contextOld.setValue(context.getValue().convertError()) + return contextOld.setValue(context.getValue().convertError()) } else { return context.toState() } @@ -256,26 +256,26 @@ define Parse { const (value) { - return ConstParser<#x>$create(value) + return ConstParser<#x>.create(value) } error (message) { - return ErrorParser$create(message) + return ErrorParser.create(message) } try (parser) { - return TryParser<#x>$create(parser) + return TryParser<#x>.create(parser) } or (parser1,parser2) { - return OrParser<#x>$create(parser1,parser2) + return OrParser<#x>.create(parser1,parser2) } left (parser1,parser2) { - return LeftParser<#x>$create(parser1,parser2) + return LeftParser<#x>.create(parser1,parser2) } right (parser1,parser2) { - return RightParser<#x>$create(parser1,parser2) + return RightParser<#x>.create(parser1,parser2) } } diff --git a/example/parser/parser-test.0rt b/example/parser/parser-test.0rt --- a/example/parser/parser-test.0rt +++ b/example/parser/parser-test.0rt @@ -1,5 +1,5 @@ testcase "parse data from a file" { - success Test$execute() + success Test.execute() } concrete Test { @@ -8,7 +8,7 @@ define Test { execute () { - TestData data <- TestData$parseFrom(loadTestData()).getValue() + TestData data <- TestData.parseFrom(loadTestData()).getValue() if (data.getName() != "example data") { fail(data.getName()) @@ -26,9 +26,9 @@ @type loadTestData () -> (String) loadTestData () { scoped { - RawFileReader reader <- RawFileReader$open($ExprLookup[MODULE_PATH]$ + "/test-data.txt") + RawFileReader reader <- RawFileReader.open($ExprLookup[MODULE_PATH]$ + "/test-data.txt") } cleanup { \ reader.freeResource() - } in return TextReader$readAll(reader) + } in return TextReader.readAll(reader) } } diff --git a/example/parser/parser.0rx b/example/parser/parser.0rx --- a/example/parser/parser.0rx +++ b/example/parser/parser.0rx @@ -13,7 +13,7 @@ if (context.hasAnyError()) { return context.getValue() } elif (!context.atEof()) { - return ErrorOr$$error("Parsing did not consume all of the data " + context.getPosition()) + return ErrorOr:error("Parsing did not consume all of the data " + context.getPosition()) } else { return context.getValue() } @@ -30,14 +30,14 @@ getValue () { if (present(error)) { - return ErrorOr$$error(require(error)) + return ErrorOr:error(require(error)) } else { return value } } convertError () { - return ParseState{ data, index, line, char, ErrorOr$$error(getError()), error } + return ParseState{ data, index, line, char, ErrorOr:error(getError()), error } } setValue (value2) { @@ -49,7 +49,7 @@ } setBrokenInput (message) { - return ParseState{ data, index, line, char, ErrorOr$$error(message), message } + return ParseState{ data, index, line, char, ErrorOr:error(message), message } } toState () { @@ -57,7 +57,7 @@ } getPosition () { - return String$builder() + return String.builder() .append("[line: ") .append(line.formatted()) .append(", char: ") @@ -94,7 +94,7 @@ @category new (String) -> (ParseState) new (data) { - return ParseState{ data, 0, 1, 1, ErrorOr$$value(Void$void()), empty } + return ParseState{ data, 0, 1, 1, ErrorOr:value(Void.void()), empty } } @value getError () -> (Formatted) @@ -109,18 +109,18 @@ @value sanityCheck () -> () sanityCheck () { if (hasBrokenInput()) { - \ LazyStream$new() + \ LazyStream.new() .append("Error at ") .append(getPosition()) .append(": ") .append(getError()) - .writeTo(SimpleOutput$error()) + .writeTo(SimpleOutput.error()) } if (atEof()) { - \ LazyStream$new() + \ LazyStream.new() .append("Reached end of input at ") .append(getPosition()) - .writeTo(SimpleOutput$error()) + .writeTo(SimpleOutput.error()) } } } diff --git a/example/parser/test-data.0rx b/example/parser/test-data.0rx --- a/example/parser/test-data.0rx +++ b/example/parser/test-data.0rx @@ -6,7 +6,7 @@ @value Bool boolean parseFrom (data) { - return TestDataParser$create() `ParseState$$consumeAll` data + return TestDataParser.create() `ParseState:consumeAll` data } create (name,description,boolean) { @@ -33,27 +33,27 @@ define TestDataParser { refines Parser - @category Parser whitespace <- SequenceOfParser$create(" \n\t",1,0) `Parse$or` Parse$error("Expected whitespace") + @category Parser whitespace <- SequenceOfParser.create(" \n\t",1,0) `Parse.or` Parse.error("Expected whitespace") @category String sentenceChars <- "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "abcdefghijklmnopqrstuvwxyz" + "., !?-" - @category Parser sentence <- SequenceOfParser$create(sentenceChars,0,0) - @category Parser quote <- CharParser$create('"') + @category Parser sentence <- SequenceOfParser.create(sentenceChars,0,0) + @category Parser quote <- CharParser.create('"') - @category Parser quotedSentence <- quote `Parse$right` sentence `Parse$left` quote - @category Parser token <- SequenceOfParser$create("ABCDEFGHIJKLMNOPQRSTUVWXYZ_",1,0) - @category Parser sentenceOrToken <- quotedSentence `Parse$or` token `Parse$left` whitespace + @category Parser quotedSentence <- quote `Parse.right` sentence `Parse.left` quote + @category Parser token <- SequenceOfParser.create("ABCDEFGHIJKLMNOPQRSTUVWXYZ_",1,0) + @category Parser sentenceOrToken <- quotedSentence `Parse.or` token `Parse.left` whitespace - @category Parser acronym <- StringParser$create("acronym") `Parse$right` Parse$const(true) - @category Parser aardvark <- StringParser$create("aardvark") `Parse$right` Parse$const(false) - @category Parser acronymOrAardvark <- Parse$try(acronym) `Parse$or` aardvark `Parse$left` whitespace + @category Parser acronym <- StringParser.create("acronym") `Parse.right` Parse.const(true) + @category Parser aardvark <- StringParser.create("aardvark") `Parse.right` Parse.const(false) + @category Parser acronymOrAardvark <- Parse.try(acronym) `Parse.or` aardvark `Parse.left` whitespace - @category Parser fileStart <- StringParser$create("file_start") `Parse$left` whitespace - @category Parser fileEnd <- StringParser$create("file_end") `Parse$left` whitespace - @category Parser nameTag <- StringParser$create("name:") `Parse$left` whitespace - @category Parser descriptionTag <- StringParser$create("description:") `Parse$left` whitespace - @category Parser aWordTag <- StringParser$create("a_word:") `Parse$left` whitespace + @category Parser fileStart <- StringParser.create("file_start") `Parse.left` whitespace + @category Parser fileEnd <- StringParser.create("file_end") `Parse.left` whitespace + @category Parser nameTag <- StringParser.create("name:") `Parse.left` whitespace + @category Parser descriptionTag <- StringParser.create("description:") `Parse.left` whitespace + @category Parser aWordTag <- StringParser.create("a_word:") `Parse.left` whitespace run (contextOld) { ParseContext context <- contextOld @@ -70,9 +70,9 @@ return context.convertError() } else { return context.setValue( - ErrorOr$$value(TestData$create(name.getValue(), - description.getValue(), - boolean.getValue()))) + ErrorOr:value(TestData.create(name.getValue(), + description.getValue(), + boolean.getValue()))) } } diff --git a/example/tree/tree-demo.0rx b/example/tree/tree-demo.0rx --- a/example/tree/tree-demo.0rx +++ b/example/tree/tree-demo.0rx @@ -4,12 +4,12 @@ define TreeDemo { run () { - TypeTree tree <- TypeTree$new() + TypeTree tree <- TypeTree.new() - TypeKey keyInt <- TypeKey$new() - TypeKey keyString <- TypeKey$new() - TypeKey keyFloat <- TypeKey$new() - TypeKey keyValue <- TypeKey$new() + TypeKey keyInt <- TypeKey.new() + TypeKey keyString <- TypeKey.new() + TypeKey keyFloat <- TypeKey.new() + TypeKey keyValue <- TypeKey.new() \ tree.set(keyInt,1) \ tree.set(keyString,"a") @@ -18,7 +18,7 @@ \ check(tree,keyString) \ check(tree,keyFloat) // Not found, since we never added a value. - \ tree.set(keyValue,Value$new()) + \ tree.set(keyValue,Value.new()) \ check(tree,keyValue) } @@ -29,16 +29,16 @@ scoped { optional #x value <- tree.get<#x>(key) } in if (present(value)) { - \ LazyStream$new() + \ LazyStream.new() .append("Found '") .append(require(value)) .append("'\n") - .writeTo(SimpleOutput$stderr()) + .writeTo(SimpleOutput.stderr()) } else { - \ LazyStream$new() + \ LazyStream.new() .append(typename>()) .append(" Not Found\n") - .writeTo(SimpleOutput$stderr()) + .writeTo(SimpleOutput.stderr()) } } } diff --git a/example/tree/tree-test.0rt b/example/tree/tree-test.0rt --- a/example/tree/tree-test.0rt +++ b/example/tree/tree-test.0rt @@ -1,11 +1,11 @@ // 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 +// 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() + success Test.execute() } // Everything past the testcase (up until the next testcase, if there is one) is @@ -19,7 +19,7 @@ define Test { execute () { // Just select the required usage patterns with an intersection. - [KVWriter&KVReader] tree <- Tree$new() + [KVWriter&KVReader] tree <- Tree.new() Int count <- 30 // Insert values. @@ -40,21 +40,21 @@ scoped { optional Int value <- tree.get(new) } in if (!present(value)) { - \ LazyStream$new() + \ LazyStream.new() .append("Not found ") .append(new) .append(" but should have been ") .append(i) - .writeTo(SimpleOutput$error()) + .writeTo(SimpleOutput.error()) } elif (require(value) != i) { - \ LazyStream$new() + \ LazyStream.new() .append("Element ") .append(new) .append(" should have been ") .append(i) .append(" but was ") .append(require(value)) - .writeTo(SimpleOutput$error()) + .writeTo(SimpleOutput.error()) } \ tree.remove(new) } update { diff --git a/example/tree/tree.0rx b/example/tree/tree.0rx --- a/example/tree/tree.0rx +++ b/example/tree/tree.0rx @@ -6,17 +6,17 @@ } set (k,v) { - root <- Node<#k,#v>$insert(root,k,v) + root <- Node<#k,#v>.insert(root,k,v) return self } remove (k) { - root <- Node<#k,#v>$delete(root,k) + root <- Node<#k,#v>.delete(root,k) return self } get (k) { - return Node<#k,#v>$find(root,k) + return Node<#k,#v>.find(root,k) } } @@ -52,10 +52,10 @@ return Node<#k,#v>{ 1, k, v, empty, empty } } Node<#k,#v> node2 <- require(node) - if (k `#k$lessThan` node2.getKey()) { + if (k `#k.lessThan` node2.getKey()) { \ node2.setLower(insert(node2.getLower(),k,v)) return rebalance(node2) - } elif (node2.getKey() `#k$lessThan` k) { + } elif (node2.getKey() `#k.lessThan` k) { \ node2.setHigher(insert(node2.getHigher(),k,v)) return rebalance(node2) } else { @@ -69,10 +69,10 @@ return empty } Node<#k,#v> node2 <- require(node) - if (k `#k$lessThan` node2.getKey()) { + if (k `#k.lessThan` node2.getKey()) { \ node2.setLower(delete(node2.getLower(),k)) return rebalance(node2) - } elif (node2.getKey() `#k$lessThan` k) { + } elif (node2.getKey() `#k.lessThan` k) { \ node2.setHigher(delete(node2.getHigher(),k)) return rebalance(node2) } else { @@ -84,9 +84,9 @@ if (present(node)) { scoped { Node<#k,#v> node2 <- require(node) - } in if (k `#k$lessThan` node2.getKey()) { + } in if (k `#k.lessThan` node2.getKey()) { return find(node2.getLower(),k) - } elif (node2.getKey() `#k$lessThan` k) { + } elif (node2.getKey() `#k.lessThan` k) { return find(node2.getHigher(),k) } else { return node2.getValue() diff --git a/example/tree/type-tree.0rx b/example/tree/type-tree.0rx --- a/example/tree/type-tree.0rx +++ b/example/tree/type-tree.0rx @@ -8,11 +8,11 @@ @value Tree,LockedType> tree new () { - return TypeTree{ Tree,LockedType>$new() } + return TypeTree{ Tree,LockedType>.new() } } set (k,v) { - \ tree.set(k,LockedType$$create(k,v)) + \ tree.set(k,LockedType:create(k,v)) return self } @@ -60,7 +60,7 @@ * both that the key and the type match. */ concrete LockedType<|#x> { - // Creates a new LockedType, e.g., LockedType$$create<#x>(k,v). + // 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. @@ -76,7 +76,7 @@ } check (k) { - if (key `TypeKey$equals` k) { + if (key `TypeKey.equals` k) { // reduce is a builtin that returns value (as optional #y) iff #x -> #y. // The runtime type of value does not matter here; it just needs to be of // type optional #x at compile time. diff --git a/lib/file/Category_RawFileReader.cpp b/lib/file/Category_RawFileReader.cpp --- a/lib/file/Category_RawFileReader.cpp +++ b/lib/file/Category_RawFileReader.cpp @@ -1,12 +1,9 @@ /* ----------------------------------------------------------------------------- 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. @@ -19,30 +16,28 @@ #include #include "category-source.hpp" -#include "Category_String.hpp" #include "Category_BlockReader.hpp" +#include "Category_Bool.hpp" +#include "Category_Formatted.hpp" +#include "Category_Int.hpp" #include "Category_PersistentResource.hpp" #include "Category_RawFileReader.hpp" - - -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -namespace ZEOLITE_DYNAMIC_NAMESPACE { -#endif // ZEOLITE_DYNAMIC_NAMESPACE - +#include "Category_String.hpp" +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE namespace { -const int collection = 0; +const int collection_RawFileReader = 0; } // namespace - -const void* const Functions_RawFileReader = &collection; +const void* const Functions_RawFileReader = &collection_RawFileReader; 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); +S CreateType_RawFileReader(Params<0>::Type params); class Value_RawFileReader; -S CreateValue(Type_RawFileReader& parent, const ParamTuple& params, const ValueTuple& args); +S CreateValue_RawFileReader(S parent, const ParamTuple& params, const ValueTuple& args); struct Category_RawFileReader : public TypeCategory { std::string CategoryName() const final { return "RawFileReader"; } Category_RawFileReader() { @@ -55,7 +50,7 @@ return TypeCategory::Dispatch(label, params, args); } }; -Category_RawFileReader& CreateCategory() { +Category_RawFileReader& CreateCategory_RawFileReader() { static auto& category = *new Category_RawFileReader(); return category; } @@ -65,25 +60,25 @@ return TypeInstance::TypeNameFrom(output, parent); } Category_RawFileReader& parent; - bool CanConvertFrom(const TypeInstance& from) const final { - std::vector args; - if (!from.TypeArgsForParent(parent, args)) return false; + bool CanConvertFrom(const S& from) const final { + std::vector> args; + if (!from->TypeArgsForParent(parent, args)) return false; if(args.size() != 0) { FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); } return true; } - bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { if (&category == &GetCategory_RawFileReader()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_PersistentResource()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_BlockReader()) { - args = std::vector{&GetType_String(T_get())}; + args = std::vector>{GetType_String(T_get())}; return true; } return false; @@ -93,8 +88,8 @@ CycleCheck marker(*this); TRACE_FUNCTION("RawFileReader (init @type)") } - ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Type_RawFileReader::*)(const ParamTuple&, const ValueTuple&); + ReturnTuple Dispatch(const S& self, const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Type_RawFileReader::*)(const S&, const ParamTuple&, const ValueTuple&); static const CallType Table_RawFileReader[] = { &Type_RawFileReader::Call_open, }; @@ -102,21 +97,20 @@ if (label.function_num < 0 || label.function_num >= 1) { FAIL() << "Bad function call " << label; } - return (this->*Table_RawFileReader[label.function_num])(params, args); + return (this->*Table_RawFileReader[label.function_num])(self, params, args); } - return TypeInstance::Dispatch(label, params, args); + return TypeInstance::Dispatch(self, label, params, args); } - ReturnTuple Call_open(const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_open(const S& self, const ParamTuple& params, const ValueTuple& args); }; -Type_RawFileReader& CreateType(Params<0>::Type params) { - static auto& cached = *new Type_RawFileReader(CreateCategory(), Params<0>::Type()); +S CreateType_RawFileReader(Params<0>::Type params) { + static const auto cached = S_get(new Type_RawFileReader(CreateCategory_RawFileReader(), Params<0>::Type())); return cached; } struct Value_RawFileReader : public TypeValue { - Value_RawFileReader(Type_RawFileReader& p, const ParamTuple& params, const ValueTuple& args) + Value_RawFileReader(S p, const ParamTuple& params, const ValueTuple& args) : parent(p), filename(args.At(0)->AsString()), - file(new std::ifstream(filename, std::ios::in | std::ios::binary)) {} - + file(new std::ifstream(filename, std::ios::in | std::ios::binary)) {} ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { using CallType = ReturnTuple(Value_RawFileReader::*)(const S&, const ParamTuple&, const ValueTuple&); static const CallType Table_BlockReader[] = { @@ -149,27 +143,24 @@ } return TypeValue::Dispatch(self, label, params, args); } - std::string CategoryName() const final { return parent.CategoryName(); } + std::string CategoryName() const final { return parent->CategoryName(); } ReturnTuple Call_freeResource(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_getFileError(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_pastEnd(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_readBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - Type_RawFileReader& parent; - + const S parent; std::mutex mutex; const std::string filename; R file; CAPTURE_CREATION }; -S CreateValue(Type_RawFileReader& parent, const ParamTuple& params, const ValueTuple& args) { +S CreateValue_RawFileReader(S 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 Type_RawFileReader::Call_open(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileReader.open") + return ReturnTuple(CreateValue_RawFileReader(CreateType_RawFileReader(Params<0>::Type()), ParamTuple(), args)); } - ReturnTuple Value_RawFileReader::Call_freeResource(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { TRACE_FUNCTION("RawFileReader.freeResource") std::lock_guard lock(mutex); @@ -178,7 +169,6 @@ } return ReturnTuple(); } - ReturnTuple Value_RawFileReader::Call_getFileError(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { TRACE_FUNCTION("RawFileReader.getFileError") std::lock_guard lock(mutex); @@ -193,13 +183,11 @@ } return ReturnTuple(Var_empty); } - ReturnTuple Value_RawFileReader::Call_pastEnd(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { TRACE_FUNCTION("RawFileReader.pastEnd") std::lock_guard lock(mutex); return ReturnTuple(Box_Bool(!file || file->fail() || file->eof())); } - ReturnTuple Value_RawFileReader::Call_readBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { TRACE_FUNCTION("RawFileReader.readBlock") TRACE_CREATION @@ -228,16 +216,14 @@ } return ReturnTuple(Box_String(buffer.substr(0, read_size))); } - } // namespace TypeCategory& GetCategory_RawFileReader() { - return CreateCategory(); + return CreateCategory_RawFileReader(); } -TypeInstance& GetType_RawFileReader(Params<0>::Type params) { - return CreateType(params); +S GetType_RawFileReader(Params<0>::Type params) { + return CreateType_RawFileReader(params); } - -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -} // namespace ZEOLITE_DYNAMIC_NAMESPACE -using namespace ZEOLITE_DYNAMIC_NAMESPACE; -#endif // ZEOLITE_DYNAMIC_NAMESPACE +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/file/Category_RawFileWriter.cpp b/lib/file/Category_RawFileWriter.cpp --- a/lib/file/Category_RawFileWriter.cpp +++ b/lib/file/Category_RawFileWriter.cpp @@ -1,12 +1,10 @@ + /* ----------------------------------------------------------------------------- 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. @@ -19,30 +17,27 @@ #include #include "category-source.hpp" -#include "Category_String.hpp" #include "Category_BlockWriter.hpp" +#include "Category_Formatted.hpp" +#include "Category_Int.hpp" #include "Category_PersistentResource.hpp" #include "Category_RawFileWriter.hpp" - - -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -namespace ZEOLITE_DYNAMIC_NAMESPACE { -#endif // ZEOLITE_DYNAMIC_NAMESPACE - +#include "Category_String.hpp" +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE namespace { -const int collection = 0; +const int collection_RawFileWriter = 0; } // namespace - -const void* const Functions_RawFileWriter = &collection; +const void* const Functions_RawFileWriter = &collection_RawFileWriter; 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); +S CreateType_RawFileWriter(Params<0>::Type params); class Value_RawFileWriter; -S CreateValue(Type_RawFileWriter& parent, const ParamTuple& params, const ValueTuple& args); +S CreateValue_RawFileWriter(S parent, const ParamTuple& params, const ValueTuple& args); struct Category_RawFileWriter : public TypeCategory { std::string CategoryName() const final { return "RawFileWriter"; } Category_RawFileWriter() { @@ -55,7 +50,7 @@ return TypeCategory::Dispatch(label, params, args); } }; -Category_RawFileWriter& CreateCategory() { +Category_RawFileWriter& CreateCategory_RawFileWriter() { static auto& category = *new Category_RawFileWriter(); return category; } @@ -65,25 +60,25 @@ return TypeInstance::TypeNameFrom(output, parent); } Category_RawFileWriter& parent; - bool CanConvertFrom(const TypeInstance& from) const final { - std::vector args; - if (!from.TypeArgsForParent(parent, args)) return false; + bool CanConvertFrom(const S& from) const final { + std::vector> args; + if (!from->TypeArgsForParent(parent, args)) return false; if(args.size() != 0) { FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); } return true; } - bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { if (&category == &GetCategory_RawFileWriter()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_PersistentResource()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_BlockWriter()) { - args = std::vector{&GetType_String(T_get())}; + args = std::vector>{GetType_String(T_get())}; return true; } return false; @@ -93,8 +88,8 @@ CycleCheck marker(*this); TRACE_FUNCTION("RawFileWriter (init @type)") } - ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Type_RawFileWriter::*)(const ParamTuple&, const ValueTuple&); + ReturnTuple Dispatch(const S& self, const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Type_RawFileWriter::*)(const S&, const ParamTuple&, const ValueTuple&); static const CallType Table_RawFileWriter[] = { &Type_RawFileWriter::Call_open, }; @@ -102,21 +97,20 @@ if (label.function_num < 0 || label.function_num >= 1) { FAIL() << "Bad function call " << label; } - return (this->*Table_RawFileWriter[label.function_num])(params, args); + return (this->*Table_RawFileWriter[label.function_num])(self, params, args); } - return TypeInstance::Dispatch(label, params, args); + return TypeInstance::Dispatch(self, label, params, args); } - ReturnTuple Call_open(const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_open(const S& self, const ParamTuple& params, const ValueTuple& args); }; -Type_RawFileWriter& CreateType(Params<0>::Type params) { - static auto& cached = *new Type_RawFileWriter(CreateCategory(), Params<0>::Type()); +S CreateType_RawFileWriter(Params<0>::Type params) { + static const auto cached = S_get(new Type_RawFileWriter(CreateCategory_RawFileWriter(), Params<0>::Type())); return cached; } struct Value_RawFileWriter : public TypeValue { - Value_RawFileWriter(Type_RawFileWriter& p, const ParamTuple& params, const ValueTuple& args) + Value_RawFileWriter(S p, const ParamTuple& params, const ValueTuple& args) : parent(p), filename(args.At(0)->AsString()), - file(new std::ofstream(filename, std::ios::out | std::ios::binary | std::ios::trunc | std::ios::ate)) {} - + file(new std::ofstream(filename, std::ios::out | std::ios::binary | std::ios::trunc | std::ios::ate)) {} ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { using CallType = ReturnTuple(Value_RawFileWriter::*)(const S&, const ParamTuple&, const ValueTuple&); static const CallType Table_BlockWriter[] = { @@ -148,24 +142,22 @@ } return TypeValue::Dispatch(self, label, params, args); } - std::string CategoryName() const final { return parent.CategoryName(); } + std::string CategoryName() const final { return parent->CategoryName(); } ReturnTuple Call_freeResource(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_getFileError(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_writeBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - Type_RawFileWriter& parent; - + const S parent; std::mutex mutex; const std::string filename; R file; CAPTURE_CREATION }; -S CreateValue(Type_RawFileWriter& parent, const ParamTuple& params, const ValueTuple& args) { +S CreateValue_RawFileWriter(S 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 Type_RawFileWriter::Call_open(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileWriter.open") + return ReturnTuple(CreateValue_RawFileWriter(CreateType_RawFileWriter(Params<0>::Type()), ParamTuple(), args)); } ReturnTuple Value_RawFileWriter::Call_freeResource(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { TRACE_FUNCTION("RawFileWriter.freeResource") @@ -205,17 +197,14 @@ } return ReturnTuple(Box_Int(write_size)); } - } // namespace - TypeCategory& GetCategory_RawFileWriter() { - return CreateCategory(); + return CreateCategory_RawFileWriter(); } -TypeInstance& GetType_RawFileWriter(Params<0>::Type params) { - return CreateType(params); +S GetType_RawFileWriter(Params<0>::Type params) { + return CreateType_RawFileWriter(params); } - -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -} // namespace ZEOLITE_DYNAMIC_NAMESPACE -using namespace ZEOLITE_DYNAMIC_NAMESPACE; -#endif // ZEOLITE_DYNAMIC_NAMESPACE +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/file/tests.0rt b/lib/file/tests.0rt --- a/lib/file/tests.0rt +++ b/lib/file/tests.0rt @@ -17,16 +17,16 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "read and write" { - success Test$run() + success Test.run() } define Test { run () { - RawFileWriter writer <- RawFileWriter$open("testfile") + RawFileWriter writer <- RawFileWriter.open("testfile") if (present(writer.getFileError())) { fail(require(writer.getFileError())) } - RawFileReader reader <- RawFileReader$open("testfile") + RawFileReader reader <- RawFileReader.open("testfile") if (present(reader.getFileError())) { fail(require(reader.getFileError())) } @@ -67,13 +67,13 @@ testcase "read empty file" { - success Test$run() + success Test.run() } define Test { run () { - \ RawFileWriter$open("testfile").freeResource() - RawFileReader reader <- RawFileReader$open("testfile") + \ RawFileWriter.open("testfile").freeResource() + RawFileReader reader <- RawFileReader.open("testfile") String data <- reader.readBlock(10) if (data != "") { @@ -94,12 +94,12 @@ testcase "read missing file" { - success Test$run() + success Test.run() } define Test { run () { - RawFileReader reader <- RawFileReader$open("do-not-create-this-file") + RawFileReader reader <- RawFileReader.open("do-not-create-this-file") if (!present(reader.getFileError())) { fail("expected file error") } @@ -112,14 +112,14 @@ testcase "read missing file crash" { - crash Test$run() + crash Test.run() require "do-not-create-this-file" require "RawFileReader .*originally created" } define Test { run () { - RawFileReader reader <- RawFileReader$open("do-not-create-this-file") + RawFileReader reader <- RawFileReader.open("do-not-create-this-file") \ reader.readBlock(0) } } @@ -130,12 +130,12 @@ testcase "unwritable file" { - success Test$run() + success Test.run() } define Test { run () { - RawFileWriter writer <- RawFileWriter$open("testfile") + RawFileWriter writer <- RawFileWriter.open("testfile") \ writer.freeResource() if (!present(writer.getFileError())) { fail("expected file error") @@ -149,14 +149,14 @@ testcase "unwritable file crash" { - crash Test$run() + crash Test.run() require "testfile" require "RawFileWriter .*originally created" } define Test { run () { - RawFileWriter writer <- RawFileWriter$open("testfile") + RawFileWriter writer <- RawFileWriter.open("testfile") \ writer.freeResource() \ writer.writeBlock("") } diff --git a/lib/math/.zeolite-module b/lib/math/.zeolite-module --- a/lib/math/.zeolite-module +++ b/lib/math/.zeolite-module @@ -8,5 +8,10 @@ source: "lib/math/Category_Math.cpp" categories: [Math] } + category_source { + source: "lib/math/Source_Math.cpp" + categories: [Math] + } + "lib/math/Source_Math.hpp" ] mode: incremental {} diff --git a/lib/math/Category_Math.cpp b/lib/math/Category_Math.cpp --- a/lib/math/Category_Math.cpp +++ b/lib/math/Category_Math.cpp @@ -18,344 +18,202 @@ #include -#include "category-source.hpp" +#include "Source_Math.hpp" #include "Category_Float.hpp" -#include "Category_Formatted.hpp" -#include "Category_Math.hpp" #include "Category_String.hpp" -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -namespace ZEOLITE_DYNAMIC_NAMESPACE { -#endif // ZEOLITE_DYNAMIC_NAMESPACE -namespace { -const int collection_Math = 0; -} // namespace -const void* const Functions_Math = &collection_Math; -const TypeFunction& Function_Math_acos = (*new TypeFunction{ 0, 1, 1, "Math", "acos", Functions_Math, 0 }); -const TypeFunction& Function_Math_acosh = (*new TypeFunction{ 0, 1, 1, "Math", "acosh", Functions_Math, 1 }); -const TypeFunction& Function_Math_asin = (*new TypeFunction{ 0, 1, 1, "Math", "asin", Functions_Math, 2 }); -const TypeFunction& Function_Math_asinh = (*new TypeFunction{ 0, 1, 1, "Math", "asinh", Functions_Math, 3 }); -const TypeFunction& Function_Math_atan = (*new TypeFunction{ 0, 1, 1, "Math", "atan", Functions_Math, 4 }); -const TypeFunction& Function_Math_atanh = (*new TypeFunction{ 0, 1, 1, "Math", "atanh", Functions_Math, 5 }); -const TypeFunction& Function_Math_ceil = (*new TypeFunction{ 0, 1, 1, "Math", "ceil", Functions_Math, 6 }); -const TypeFunction& Function_Math_cos = (*new TypeFunction{ 0, 1, 1, "Math", "cos", Functions_Math, 7 }); -const TypeFunction& Function_Math_cosh = (*new TypeFunction{ 0, 1, 1, "Math", "cosh", Functions_Math, 8 }); -const TypeFunction& Function_Math_exp = (*new TypeFunction{ 0, 1, 1, "Math", "exp", Functions_Math, 9 }); -const TypeFunction& Function_Math_fabs = (*new TypeFunction{ 0, 1, 1, "Math", "fabs", Functions_Math, 10 }); -const TypeFunction& Function_Math_floor = (*new TypeFunction{ 0, 1, 1, "Math", "floor", Functions_Math, 11 }); -const TypeFunction& Function_Math_fmod = (*new TypeFunction{ 0, 2, 1, "Math", "fmod", Functions_Math, 12 }); -const TypeFunction& Function_Math_isinf = (*new TypeFunction{ 0, 1, 1, "Math", "isinf", Functions_Math, 13 }); -const TypeFunction& Function_Math_isnan = (*new TypeFunction{ 0, 1, 1, "Math", "isnan", Functions_Math, 14 }); -const TypeFunction& Function_Math_log = (*new TypeFunction{ 0, 1, 1, "Math", "log", Functions_Math, 15 }); -const TypeFunction& Function_Math_log10 = (*new TypeFunction{ 0, 1, 1, "Math", "log10", Functions_Math, 16 }); -const TypeFunction& Function_Math_log2 = (*new TypeFunction{ 0, 1, 1, "Math", "log2", Functions_Math, 17 }); -const TypeFunction& Function_Math_pow = (*new TypeFunction{ 0, 2, 1, "Math", "pow", Functions_Math, 18 }); -const TypeFunction& Function_Math_round = (*new TypeFunction{ 0, 1, 1, "Math", "round", Functions_Math, 19 }); -const TypeFunction& Function_Math_sin = (*new TypeFunction{ 0, 1, 1, "Math", "sin", Functions_Math, 20 }); -const TypeFunction& Function_Math_sinh = (*new TypeFunction{ 0, 1, 1, "Math", "sinh", Functions_Math, 21 }); -const TypeFunction& Function_Math_sqrt = (*new TypeFunction{ 0, 1, 1, "Math", "sqrt", Functions_Math, 22 }); -const TypeFunction& Function_Math_tan = (*new TypeFunction{ 0, 1, 1, "Math", "tan", Functions_Math, 23 }); -const TypeFunction& Function_Math_tanh = (*new TypeFunction{ 0, 1, 1, "Math", "tanh", Functions_Math, 24 }); -const TypeFunction& Function_Math_trunc = (*new TypeFunction{ 0, 1, 1, "Math", "trunc", Functions_Math, 25 }); +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE + namespace { -class Category_Math; -class Type_Math; -Type_Math& CreateType_Math(Params<0>::Type params); -class Value_Math; -S CreateValue_Math(Type_Math& parent, const ParamTuple& params, const ValueTuple& args); -struct Category_Math : public TypeCategory { - std::string CategoryName() const final { return "Math"; } - Category_Math() { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("Math (init @category)") - } - ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Category_Math::*)(const ParamTuple&, const ValueTuple&); - return TypeCategory::Dispatch(label, params, args); - } -}; -Category_Math& CreateCategory_Math() { - static auto& category = *new Category_Math(); - return category; -} -struct Type_Math : public TypeInstance { - std::string CategoryName() const final { return parent.CategoryName(); } - void BuildTypeName(std::ostream& output) const final { - return TypeInstance::TypeNameFrom(output, parent); - } - Category_Math& parent; - bool CanConvertFrom(const TypeInstance& from) const final { - std::vector args; - if (!from.TypeArgsForParent(parent, args)) return false; - if(args.size() != 0) { - FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); - } - return true; - } - bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { - if (&category == &GetCategory_Math()) { - args = std::vector{}; - return true; - } - return false; + +struct Impl_Category_Math : public Category_Math {}; + +struct Impl_Type_Math : public Type_Math { + Impl_Type_Math(Category_Math& p, Params<0>::Type params) : Type_Math(p, std::move(params)) {} + + ReturnTuple Call_acos(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.acos") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::acos(Var_arg1))); } - Type_Math(Category_Math& p, Params<0>::Type params) : parent(p) { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("Math (init @type)") + + ReturnTuple Call_acosh(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.acosh") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::acosh(Var_arg1))); } - ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Type_Math::*)(const ParamTuple&, const ValueTuple&); - static const CallType Table_Math[] = { - &Type_Math::Call_acos, - &Type_Math::Call_acosh, - &Type_Math::Call_asin, - &Type_Math::Call_asinh, - &Type_Math::Call_atan, - &Type_Math::Call_atanh, - &Type_Math::Call_ceil, - &Type_Math::Call_cos, - &Type_Math::Call_cosh, - &Type_Math::Call_exp, - &Type_Math::Call_fabs, - &Type_Math::Call_floor, - &Type_Math::Call_fmod, - &Type_Math::Call_isinf, - &Type_Math::Call_isnan, - &Type_Math::Call_log, - &Type_Math::Call_log10, - &Type_Math::Call_log2, - &Type_Math::Call_pow, - &Type_Math::Call_round, - &Type_Math::Call_sin, - &Type_Math::Call_sinh, - &Type_Math::Call_sqrt, - &Type_Math::Call_tan, - &Type_Math::Call_tanh, - &Type_Math::Call_trunc, - }; - if (label.collection == Functions_Math) { - if (label.function_num < 0 || label.function_num >= 26) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_Math[label.function_num])(params, args); - } - return TypeInstance::Dispatch(label, params, args); + + ReturnTuple Call_asin(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.asin") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::asin(Var_arg1))); } - ReturnTuple Call_acos(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_acosh(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_asin(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_asinh(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_atan(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_atanh(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_ceil(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_cos(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_cosh(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_exp(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_fabs(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_floor(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_fmod(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_isinf(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_isnan(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_log(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_log10(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_log2(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_pow(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_round(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_sin(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_sinh(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_sqrt(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_tan(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_tanh(const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_trunc(const ParamTuple& params, const ValueTuple& args); -}; -Type_Math& CreateType_Math(Params<0>::Type params) { - static auto& cached = *new Type_Math(CreateCategory_Math(), Params<0>::Type()); - return cached; -} -struct Value_Math : public TypeValue { - Value_Math(Type_Math& p, const ParamTuple& params, const ValueTuple& args) : parent(p) {} - ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { - using CallType = ReturnTuple(Value_Math::*)(const S&, const ParamTuple&, const ValueTuple&); - return TypeValue::Dispatch(self, label, params, args); + + ReturnTuple Call_asinh(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.asinh") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::asinh(Var_arg1))); } - std::string CategoryName() const final { return parent.CategoryName(); } - Type_Math& parent; -}; -S CreateValue_Math(Type_Math& parent, const ParamTuple& params, const ValueTuple& args) { - return S_get(new Value_Math(parent, params, args)); -} -ReturnTuple Type_Math::Call_acos(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.acos") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::acos(Var_arg1))); -} + ReturnTuple Call_atan(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.atan") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::atan(Var_arg1))); + } -ReturnTuple Type_Math::Call_acosh(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.acosh") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::acosh(Var_arg1))); -} + ReturnTuple Call_atanh(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.atanh") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::atanh(Var_arg1))); + } -ReturnTuple Type_Math::Call_asin(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.asin") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::asin(Var_arg1))); -} + ReturnTuple Call_ceil(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.ceil") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::ceil(Var_arg1))); + } -ReturnTuple Type_Math::Call_asinh(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.asinh") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::asinh(Var_arg1))); -} + ReturnTuple Call_cos(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.cos") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::cos(Var_arg1))); + } -ReturnTuple Type_Math::Call_atan(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.atan") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::atan(Var_arg1))); -} + ReturnTuple Call_cosh(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.cosh") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::cosh(Var_arg1))); + } -ReturnTuple Type_Math::Call_atanh(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.atanh") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::atanh(Var_arg1))); -} + ReturnTuple Call_exp(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.exp") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::exp(Var_arg1))); + } -ReturnTuple Type_Math::Call_ceil(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.ceil") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::ceil(Var_arg1))); -} + ReturnTuple Call_fabs(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.fabs") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::fabs(Var_arg1))); + } -ReturnTuple Type_Math::Call_cos(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.cos") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::cos(Var_arg1))); -} + ReturnTuple Call_floor(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.floor") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::floor(Var_arg1))); + } -ReturnTuple Type_Math::Call_cosh(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.cosh") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::cosh(Var_arg1))); -} + ReturnTuple Call_fmod(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.fmod") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + const PrimFloat Var_arg2 = (args.At(1))->AsFloat(); + return ReturnTuple(Box_Float(std::fmod(Var_arg1,Var_arg2))); + } -ReturnTuple Type_Math::Call_exp(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.exp") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::exp(Var_arg1))); -} + ReturnTuple Call_isinf(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.isinf") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Bool(std::isinf(Var_arg1))); + } -ReturnTuple Type_Math::Call_fabs(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.fabs") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::fabs(Var_arg1))); -} + ReturnTuple Call_isnan(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.isnan") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Bool(std::isnan(Var_arg1))); + } -ReturnTuple Type_Math::Call_floor(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.floor") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::floor(Var_arg1))); -} + ReturnTuple Call_log(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.log") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::log(Var_arg1))); + } -ReturnTuple Type_Math::Call_fmod(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.fmod") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - const PrimFloat Var_arg2 = (args.At(1))->AsFloat(); - return ReturnTuple(Box_Float(std::fmod(Var_arg1,Var_arg2))); -} + ReturnTuple Call_log10(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.log10") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::log10(Var_arg1))); + } -ReturnTuple Type_Math::Call_isinf(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.isinf") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Bool(std::isinf(Var_arg1))); -} + ReturnTuple Call_log2(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.log2") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::log2(Var_arg1))); + } -ReturnTuple Type_Math::Call_isnan(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.isnan") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Bool(std::isnan(Var_arg1))); -} + ReturnTuple Call_pow(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.pow") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + const PrimFloat Var_arg2 = (args.At(1))->AsFloat(); + return ReturnTuple(Box_Float(std::pow(Var_arg1,Var_arg2))); + } -ReturnTuple Type_Math::Call_log(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.log") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::log(Var_arg1))); -} + ReturnTuple Call_round(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.round") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::round(Var_arg1))); + } -ReturnTuple Type_Math::Call_log10(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.log10") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::log10(Var_arg1))); -} + ReturnTuple Call_sin(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.sin") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::sin(Var_arg1))); + } -ReturnTuple Type_Math::Call_log2(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.log2") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::log2(Var_arg1))); -} + ReturnTuple Call_sinh(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.sinh") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::sinh(Var_arg1))); + } -ReturnTuple Type_Math::Call_pow(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.pow") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - const PrimFloat Var_arg2 = (args.At(1))->AsFloat(); - return ReturnTuple(Box_Float(std::pow(Var_arg1,Var_arg2))); -} + ReturnTuple Call_sqrt(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.sqrt") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::sqrt(Var_arg1))); + } -ReturnTuple Type_Math::Call_round(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.round") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::round(Var_arg1))); -} + ReturnTuple Call_tan(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.tan") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::tan(Var_arg1))); + } -ReturnTuple Type_Math::Call_sin(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.sin") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::sin(Var_arg1))); -} + ReturnTuple Call_tanh(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.tanh") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::tanh(Var_arg1))); + } -ReturnTuple Type_Math::Call_sinh(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.sinh") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::sinh(Var_arg1))); -} + ReturnTuple Call_trunc(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.trunc") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::trunc(Var_arg1))); + } +}; -ReturnTuple Type_Math::Call_sqrt(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.sqrt") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::sqrt(Var_arg1))); -} +struct Impl_Value_Math : public Value_Math { + Impl_Value_Math(S p, const ParamTuple& params, const ValueTuple& args) : Value_Math(p) {} +}; -ReturnTuple Type_Math::Call_tan(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.tan") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::tan(Var_arg1))); -} +} // namespace -ReturnTuple Type_Math::Call_tanh(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.tanh") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::tanh(Var_arg1))); +Category_Math& CreateCategory_Math() { + static auto& category = *new Impl_Category_Math(); + return category; } -ReturnTuple Type_Math::Call_trunc(const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Math.trunc") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::trunc(Var_arg1))); +S CreateType_Math(Params<0>::Type params) { + static const auto cached = S_get(new Impl_Type_Math(CreateCategory_Math(), Params<0>::Type())); + return cached; } -} // namespace - -TypeCategory& GetCategory_Math() { - return CreateCategory_Math(); -} -TypeInstance& GetType_Math(Params<0>::Type params) { - return CreateType_Math(params); +S CreateValue_Math(S parent, const ParamTuple& params, const ValueTuple& args) { + return S_get(new Impl_Value_Math(parent, params, args)); } -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -} // namespace ZEOLITE_DYNAMIC_NAMESPACE -using namespace ZEOLITE_DYNAMIC_NAMESPACE; -#endif // ZEOLITE_DYNAMIC_NAMESPACE +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/math/Source_Math.cpp b/lib/math/Source_Math.cpp new file mode 100644 --- /dev/null +++ b/lib/math/Source_Math.cpp @@ -0,0 +1,160 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#include + +#include "Source_Math.hpp" + + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +namespace ZEOLITE_DYNAMIC_NAMESPACE { +#endif // ZEOLITE_DYNAMIC_NAMESPACE + +namespace { +const int collection_Math = 0; +} // namespace +const void* const Functions_Math = &collection_Math; +const TypeFunction& Function_Math_acos = (*new TypeFunction{ 0, 1, 1, "Math", "acos", Functions_Math, 0 }); +const TypeFunction& Function_Math_acosh = (*new TypeFunction{ 0, 1, 1, "Math", "acosh", Functions_Math, 1 }); +const TypeFunction& Function_Math_asin = (*new TypeFunction{ 0, 1, 1, "Math", "asin", Functions_Math, 2 }); +const TypeFunction& Function_Math_asinh = (*new TypeFunction{ 0, 1, 1, "Math", "asinh", Functions_Math, 3 }); +const TypeFunction& Function_Math_atan = (*new TypeFunction{ 0, 1, 1, "Math", "atan", Functions_Math, 4 }); +const TypeFunction& Function_Math_atanh = (*new TypeFunction{ 0, 1, 1, "Math", "atanh", Functions_Math, 5 }); +const TypeFunction& Function_Math_ceil = (*new TypeFunction{ 0, 1, 1, "Math", "ceil", Functions_Math, 6 }); +const TypeFunction& Function_Math_cos = (*new TypeFunction{ 0, 1, 1, "Math", "cos", Functions_Math, 7 }); +const TypeFunction& Function_Math_cosh = (*new TypeFunction{ 0, 1, 1, "Math", "cosh", Functions_Math, 8 }); +const TypeFunction& Function_Math_exp = (*new TypeFunction{ 0, 1, 1, "Math", "exp", Functions_Math, 9 }); +const TypeFunction& Function_Math_fabs = (*new TypeFunction{ 0, 1, 1, "Math", "fabs", Functions_Math, 10 }); +const TypeFunction& Function_Math_floor = (*new TypeFunction{ 0, 1, 1, "Math", "floor", Functions_Math, 11 }); +const TypeFunction& Function_Math_fmod = (*new TypeFunction{ 0, 2, 1, "Math", "fmod", Functions_Math, 12 }); +const TypeFunction& Function_Math_isinf = (*new TypeFunction{ 0, 1, 1, "Math", "isinf", Functions_Math, 13 }); +const TypeFunction& Function_Math_isnan = (*new TypeFunction{ 0, 1, 1, "Math", "isnan", Functions_Math, 14 }); +const TypeFunction& Function_Math_log = (*new TypeFunction{ 0, 1, 1, "Math", "log", Functions_Math, 15 }); +const TypeFunction& Function_Math_log10 = (*new TypeFunction{ 0, 1, 1, "Math", "log10", Functions_Math, 16 }); +const TypeFunction& Function_Math_log2 = (*new TypeFunction{ 0, 1, 1, "Math", "log2", Functions_Math, 17 }); +const TypeFunction& Function_Math_pow = (*new TypeFunction{ 0, 2, 1, "Math", "pow", Functions_Math, 18 }); +const TypeFunction& Function_Math_round = (*new TypeFunction{ 0, 1, 1, "Math", "round", Functions_Math, 19 }); +const TypeFunction& Function_Math_sin = (*new TypeFunction{ 0, 1, 1, "Math", "sin", Functions_Math, 20 }); +const TypeFunction& Function_Math_sinh = (*new TypeFunction{ 0, 1, 1, "Math", "sinh", Functions_Math, 21 }); +const TypeFunction& Function_Math_sqrt = (*new TypeFunction{ 0, 1, 1, "Math", "sqrt", Functions_Math, 22 }); +const TypeFunction& Function_Math_tan = (*new TypeFunction{ 0, 1, 1, "Math", "tan", Functions_Math, 23 }); +const TypeFunction& Function_Math_tanh = (*new TypeFunction{ 0, 1, 1, "Math", "tanh", Functions_Math, 24 }); +const TypeFunction& Function_Math_trunc = (*new TypeFunction{ 0, 1, 1, "Math", "trunc", Functions_Math, 25 }); + +std::string Category_Math::CategoryName() const { return "Math"; } + +Category_Math::Category_Math() { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("Math (init @category)") +} + +ReturnTuple Category_Math::Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) { + using CallType = ReturnTuple(Category_Math::*)(const ParamTuple&, const ValueTuple&); + return TypeCategory::Dispatch(label, params, args); +} + +Type_Math::Type_Math(Category_Math& p, Params<0>::Type params) : parent(p) { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("Math (init @type)") +} + +std::string Type_Math::CategoryName() const { return parent.CategoryName(); } + +void Type_Math::BuildTypeName(std::ostream& output) const { + return TypeInstance::TypeNameFrom(output, parent); +} + +bool Type_Math::CanConvertFrom(const S& from) const { + std::vector> args; + if (!from->TypeArgsForParent(parent, args)) return false; + if(args.size() != 0) { + FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); + } + return true; +} + +bool Type_Math::TypeArgsForParent(const TypeCategory& category, std::vector>& args) const { + if (&category == &GetCategory_Math()) { + args = std::vector>{}; + return true; + } + return false; +} + +ReturnTuple Type_Math::Dispatch(const S& self, const TypeFunction& label, + const ParamTuple& params, const ValueTuple& args) { + using CallType = ReturnTuple(Type_Math::*)(const S&, const ParamTuple&, const ValueTuple&); + static const CallType Table_Math[] = { + &Type_Math::Call_acos, + &Type_Math::Call_acosh, + &Type_Math::Call_asin, + &Type_Math::Call_asinh, + &Type_Math::Call_atan, + &Type_Math::Call_atanh, + &Type_Math::Call_ceil, + &Type_Math::Call_cos, + &Type_Math::Call_cosh, + &Type_Math::Call_exp, + &Type_Math::Call_fabs, + &Type_Math::Call_floor, + &Type_Math::Call_fmod, + &Type_Math::Call_isinf, + &Type_Math::Call_isnan, + &Type_Math::Call_log, + &Type_Math::Call_log10, + &Type_Math::Call_log2, + &Type_Math::Call_pow, + &Type_Math::Call_round, + &Type_Math::Call_sin, + &Type_Math::Call_sinh, + &Type_Math::Call_sqrt, + &Type_Math::Call_tan, + &Type_Math::Call_tanh, + &Type_Math::Call_trunc, + }; + if (label.collection == Functions_Math) { + if (label.function_num < 0 || label.function_num >= 26) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_Math[label.function_num])(self, params, args); + } + return TypeInstance::Dispatch(self, label, params, args); +} + +Value_Math::Value_Math(S p) : parent(p) {} + +ReturnTuple Value_Math::Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) { + using CallType = ReturnTuple(Value_Math::*)(const S&, const ParamTuple&, const ValueTuple&); + return TypeValue::Dispatch(self, label, params, args); +} + +std::string Value_Math::CategoryName() const { return parent->CategoryName(); } + +TypeCategory& GetCategory_Math() { + return CreateCategory_Math(); +} +S GetType_Math(Params<0>::Type params) { + return CreateType_Math(params); +} + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +} // namespace ZEOLITE_DYNAMIC_NAMESPACE +using namespace ZEOLITE_DYNAMIC_NAMESPACE; +#endif // ZEOLITE_DYNAMIC_NAMESPACE diff --git a/lib/math/Source_Math.hpp b/lib/math/Source_Math.hpp new file mode 100644 --- /dev/null +++ b/lib/math/Source_Math.hpp @@ -0,0 +1,111 @@ +/* ----------------------------------------------------------------------------- +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 HEADER_Source_Math +#define HEADER_Source_Math + +#include + +#include "category-source.hpp" +#include "Category_Math.hpp" + + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +namespace ZEOLITE_DYNAMIC_NAMESPACE { +#endif // ZEOLITE_DYNAMIC_NAMESPACE + +class Category_Math : public TypeCategory { + public: + std::string CategoryName() const final; + + ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final; + + protected: + Category_Math(); +}; + +class Type_Math : public TypeInstance { + public: + std::string CategoryName() const final; + + void BuildTypeName(std::ostream& output) const final; + + bool CanConvertFrom(const S& from) const final; + + bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final; + + ReturnTuple Dispatch(const S& self, const TypeFunction& label, + const ParamTuple& params, const ValueTuple& args) final; + + protected: + Type_Math(Category_Math& p, Params<0>::Type params); + + virtual ReturnTuple Call_acos(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_acosh(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_asin(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_asinh(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_atan(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_atanh(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_ceil(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_cos(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_cosh(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_exp(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_fabs(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_floor(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_fmod(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_isinf(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_isnan(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_log(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_log10(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_log2(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_pow(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_round(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_sin(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_sinh(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_sqrt(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_tan(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_tanh(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + virtual ReturnTuple Call_trunc(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; + + Category_Math& parent; +}; + +class Value_Math : public TypeValue { + public: + ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final; + + std::string CategoryName() const final; + + protected: + Value_Math(S p); + + S parent; +}; + +Category_Math& CreateCategory_Math(); + +S CreateType_Math(Params<0>::Type params); + +S CreateValue_Math(Type_Math& parent, const ParamTuple& params, const ValueTuple& args); + +#ifdef ZEOLITE_DYNAMIC_NAMESPACE +} // namespace ZEOLITE_DYNAMIC_NAMESPACE +using namespace ZEOLITE_DYNAMIC_NAMESPACE; +#endif // ZEOLITE_DYNAMIC_NAMESPACE + +#endif // HEADER_Source_Math diff --git a/lib/math/tests.0rt b/lib/math/tests.0rt --- a/lib/math/tests.0rt +++ b/lib/math/tests.0rt @@ -17,39 +17,39 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "sanity check all functions" { - success Test$run() + success Test.run() } define Test { run () { - \ Testing$checkBetween(Math$cos(2.0),-0.42,-0.41) - \ Testing$checkBetween(Math$sin(2.0),0.90,0.91) - \ Testing$checkBetween(Math$tan(2.0),-2.19,-2.18) - \ Testing$checkBetween(Math$acos(0.5),1.04,1.05) - \ Testing$checkBetween(Math$asin(0.5),0.52,0.53) - \ Testing$checkBetween(Math$atan(0.5),0.46,0.47) - \ Testing$checkBetween(Math$cosh(2.0),3.76,3.77) - \ Testing$checkBetween(Math$sinh(2.0),3.62,3.63) - \ Testing$checkBetween(Math$tanh(2.0),0.96,0.97) - \ Testing$checkBetween(Math$acosh(2.0),1.31,1.32) - \ Testing$checkBetween(Math$asinh(2.0),1.44,1.45) - \ Testing$checkBetween(Math$atanh(0.5),0.54,0.55) - \ Testing$checkBetween(Math$exp(1.0),2.71,2.72) - \ Testing$checkBetween(Math$log(9.0),2.19,2.20) - \ Testing$checkBetween(Math$log10(100.0),1.99,2.01) - \ Testing$checkBetween(Math$log2(8.0),2.99,3.01) - \ Testing$checkBetween(Math$pow(2.0,3.0),7.99,8.01) - \ Testing$checkBetween(Math$sqrt(4.0),1.99,2.01) - \ Testing$checkBetween(Math$ceil(2.2),2.99,3.01) - \ Testing$checkBetween(Math$floor(2.2),1.99,2.01) - \ Testing$checkBetween(Math$fmod(7.0,4.0),2.99,3.01) - \ Testing$checkBetween(Math$trunc(2.2),1.99,2.01) - \ Testing$checkBetween(Math$round(2.7),2.99,3.01) - \ Testing$checkBetween(Math$fabs(-10.0),9.99,10.01) - if (!Math$isinf(Math$log(0.0))) { + \ Testing.checkBetween(Math.cos(2.0),-0.42,-0.41) + \ Testing.checkBetween(Math.sin(2.0),0.90,0.91) + \ Testing.checkBetween(Math.tan(2.0),-2.19,-2.18) + \ Testing.checkBetween(Math.acos(0.5),1.04,1.05) + \ Testing.checkBetween(Math.asin(0.5),0.52,0.53) + \ Testing.checkBetween(Math.atan(0.5),0.46,0.47) + \ Testing.checkBetween(Math.cosh(2.0),3.76,3.77) + \ Testing.checkBetween(Math.sinh(2.0),3.62,3.63) + \ Testing.checkBetween(Math.tanh(2.0),0.96,0.97) + \ Testing.checkBetween(Math.acosh(2.0),1.31,1.32) + \ Testing.checkBetween(Math.asinh(2.0),1.44,1.45) + \ Testing.checkBetween(Math.atanh(0.5),0.54,0.55) + \ Testing.checkBetween(Math.exp(1.0),2.71,2.72) + \ Testing.checkBetween(Math.log(9.0),2.19,2.20) + \ Testing.checkBetween(Math.log10(100.0),1.99,2.01) + \ Testing.checkBetween(Math.log2(8.0),2.99,3.01) + \ Testing.checkBetween(Math.pow(2.0,3.0),7.99,8.01) + \ Testing.checkBetween(Math.sqrt(4.0),1.99,2.01) + \ Testing.checkBetween(Math.ceil(2.2),2.99,3.01) + \ Testing.checkBetween(Math.floor(2.2),1.99,2.01) + \ Testing.checkBetween(Math.fmod(7.0,4.0),2.99,3.01) + \ Testing.checkBetween(Math.trunc(2.2),1.99,2.01) + \ Testing.checkBetween(Math.round(2.7),2.99,3.01) + \ Testing.checkBetween(Math.fabs(-10.0),9.99,10.01) + if (!Math.isinf(Math.log(0.0))) { fail("Failed") } - if (!Math$isnan(Math$sqrt(-1.0))) { + if (!Math.isnan(Math.sqrt(-1.0))) { fail("Failed") } } diff --git a/lib/util/Category_Argv.cpp b/lib/util/Category_Argv.cpp --- a/lib/util/Category_Argv.cpp +++ b/lib/util/Category_Argv.cpp @@ -1,12 +1,9 @@ /* ----------------------------------------------------------------------------- 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. @@ -18,30 +15,25 @@ #include "category-source.hpp" #include "Category_Argv.hpp" +#include "Category_Formatted.hpp" +#include "Category_Int.hpp" #include "Category_ReadPosition.hpp" #include "Category_String.hpp" - - -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -namespace ZEOLITE_DYNAMIC_NAMESPACE { -#endif // ZEOLITE_DYNAMIC_NAMESPACE - +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE namespace { - extern const S& Var_global; - -const int collection = 0; +const int collection_Argv = 0; } // namespace - -const void* const Functions_Argv = &collection; +const void* const Functions_Argv = &collection_Argv; 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); +S CreateType_Argv(Params<0>::Type params); class Value_Argv; -S CreateValue(Type_Argv& parent, const ParamTuple& params, const ValueTuple& args); +S CreateValue_Argv(S parent, const ParamTuple& params, const ValueTuple& args); struct Category_Argv : public TypeCategory { std::string CategoryName() const final { return "Argv"; } Category_Argv() { @@ -54,7 +46,7 @@ return TypeCategory::Dispatch(label, params, args); } }; -Category_Argv& CreateCategory() { +Category_Argv& CreateCategory_Argv() { static auto& category = *new Category_Argv(); return category; } @@ -64,21 +56,21 @@ return TypeInstance::TypeNameFrom(output, parent); } Category_Argv& parent; - bool CanConvertFrom(const TypeInstance& from) const final { - std::vector args; - if (!from.TypeArgsForParent(parent, args)) return false; + bool CanConvertFrom(const S& from) const final { + std::vector> args; + if (!from->TypeArgsForParent(parent, args)) return false; if(args.size() != 0) { FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); } return true; } - bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { if (&category == &GetCategory_Argv()) { - args = std::vector{}; + args = std::vector>{}; return true; } if (&category == &GetCategory_ReadPosition()) { - args = std::vector{&GetType_String(T_get())}; + args = std::vector>{GetType_String(T_get())}; return true; } return false; @@ -88,8 +80,8 @@ CycleCheck marker(*this); TRACE_FUNCTION("Argv (init @type)") } - ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Type_Argv::*)(const ParamTuple&, const ValueTuple&); + ReturnTuple Dispatch(const S& self, const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Type_Argv::*)(const S&, const ParamTuple&, const ValueTuple&); static const CallType Table_Argv[] = { &Type_Argv::Call_global, }; @@ -97,62 +89,75 @@ if (label.function_num < 0 || label.function_num >= 1) { FAIL() << "Bad function call " << label; } - return (this->*Table_Argv[label.function_num])(params, args); + return (this->*Table_Argv[label.function_num])(self, 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); + return TypeInstance::Dispatch(self, label, params, args); } + ReturnTuple Call_global(const S& self, const ParamTuple& params, const ValueTuple& args); }; -Type_Argv& CreateType(Params<0>::Type params) { - static auto& cached = *new Type_Argv(CreateCategory(), Params<0>::Type()); +S CreateType_Argv(Params<0>::Type params) { + static const auto cached = S_get(new Type_Argv(CreateCategory_Argv(), Params<0>::Type())); return cached; } struct Value_Argv : public TypeValue { - Value_Argv(Type_Argv& p, const ParamTuple& params, const ValueTuple& args) : parent(p) {} + Value_Argv(int start, int size) : start_(start), size_(size) {} ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { using CallType = ReturnTuple(Value_Argv::*)(const S&, const ParamTuple&, const ValueTuple&); static const CallType Table_ReadPosition[] = { &Value_Argv::Call_readPosition, &Value_Argv::Call_readSize, + &Value_Argv::Call_subSequence, }; if (label.collection == Functions_ReadPosition) { - if (label.function_num < 0 || label.function_num >= 2) { + if (label.function_num < 0 || label.function_num >= 3) { FAIL() << "Bad function call " << label; } return (this->*Table_ReadPosition[label.function_num])(self, params, args); } return TypeValue::Dispatch(self, label, params, args); } - std::string CategoryName() const final { return parent.CategoryName(); } - ReturnTuple Call_readPosition(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Argv.readPosition") - const PrimInt Var_arg1 = (args.At(0))->AsInt(); - return ReturnTuple(Box_String(Argv::GetArgAt(Var_arg1))); + std::string CategoryName() const final { return "Argv"; } + inline int GetSize() const { return size_ < 0 ? Argv::ArgCount() : size_; } + ReturnTuple Call_readPosition(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_readSize(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_subSequence(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + const int start_; + const int size_; +}; +ReturnTuple Type_Argv::Call_global(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Argv.global") + return ReturnTuple(Var_global); +} +ReturnTuple Value_Argv::Call_readPosition(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Argv.readPosition") + const PrimInt Var_arg1 = (args.At(0))->AsInt(); + return ReturnTuple(Box_String(Argv::GetArgAt(start_ + Var_arg1))); +} +ReturnTuple Value_Argv::Call_readSize(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Argv.readSize") + return ReturnTuple(Box_Int(GetSize())); +} +ReturnTuple Value_Argv::Call_subSequence(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Argv.subSequence") + const PrimInt Var_arg1 = (args.At(0))->AsInt(); + const PrimInt Var_arg2 = (args.At(1))->AsInt(); + if (Var_arg1 < 0 || (Var_arg1 > 0 && Var_arg1 >= GetSize())) { + FAIL() << "Subsequence position " << Var_arg1 << " is out of bounds"; } - ReturnTuple Call_readSize(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Argv.readSize") - return ReturnTuple(Box_Int(Argv::ArgCount())); + if (Var_arg2 < 0 || Var_arg1 + Var_arg2 > GetSize()) { + FAIL() << "Subsequence size " << Var_arg2 << " is invalid"; } - Type_Argv& parent; -}; -S CreateValue(Type_Argv& parent, const ParamTuple& params, const ValueTuple& args) { - return S_get(new Value_Argv(parent, params, args)); + return ReturnTuple(S(new Value_Argv(start_ + Var_arg1, Var_arg2))); } - -const S& Var_global = *new S(CreateValue(CreateType(Params<0>::Type()), ParamTuple(), ArgTuple())); - +const S& Var_global = *new S(new Value_Argv(0, -1)); } // namespace - TypeCategory& GetCategory_Argv() { - return CreateCategory(); + return CreateCategory_Argv(); } -TypeInstance& GetType_Argv(Params<0>::Type params) { - return CreateType(params); +S GetType_Argv(Params<0>::Type params) { + return CreateType_Argv(params); } - -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -} // namespace ZEOLITE_DYNAMIC_NAMESPACE -#endif // ZEOLITE_DYNAMIC_NAMESPACE +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/util/Category_SimpleInput.cpp b/lib/util/Category_SimpleInput.cpp --- a/lib/util/Category_SimpleInput.cpp +++ b/lib/util/Category_SimpleInput.cpp @@ -1,12 +1,9 @@ /* ----------------------------------------------------------------------------- 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. @@ -20,29 +17,27 @@ #include #include "category-source.hpp" -#include "Category_SimpleInput.hpp" #include "Category_BlockReader.hpp" - - -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -namespace ZEOLITE_DYNAMIC_NAMESPACE { -#endif // ZEOLITE_DYNAMIC_NAMESPACE - +#include "Category_Bool.hpp" +#include "Category_Formatted.hpp" +#include "Category_Int.hpp" +#include "Category_SimpleInput.hpp" +#include "Category_String.hpp" +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE namespace { extern const S& Var_stdin; - -const int collection = 0; +const int collection_SimpleInput = 0; } // namespace - -const void* const Functions_SimpleInput = &collection; +const void* const Functions_SimpleInput = &collection_SimpleInput; 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); +S CreateType_SimpleInput(Params<0>::Type params); class Value_SimpleInput; -S CreateValue(Type_SimpleInput& parent, const ParamTuple& params, const ValueTuple& args); +S CreateValue_SimpleInput(S parent, const ParamTuple& params, const ValueTuple& args); struct Category_SimpleInput : public TypeCategory { std::string CategoryName() const final { return "SimpleInput"; } Category_SimpleInput() { @@ -55,7 +50,7 @@ return TypeCategory::Dispatch(label, params, args); } }; -Category_SimpleInput& CreateCategory() { +Category_SimpleInput& CreateCategory_SimpleInput() { static auto& category = *new Category_SimpleInput(); return category; } @@ -65,19 +60,23 @@ return TypeInstance::TypeNameFrom(output, parent); } Category_SimpleInput& parent; - bool CanConvertFrom(const TypeInstance& from) const final { - std::vector args; - if (!from.TypeArgsForParent(parent, args)) return false; + bool CanConvertFrom(const S& from) const final { + std::vector> args; + if (!from->TypeArgsForParent(parent, args)) return false; if(args.size() != 0) { FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); } return true; } - bool TypeArgsForParent(const TypeCategory& category, std::vector& args) const final { + bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { if (&category == &GetCategory_SimpleInput()) { - args = std::vector{}; + args = std::vector>{}; return true; } + if (&category == &GetCategory_BlockReader()) { + args = std::vector>{GetType_String(T_get())}; + return true; + } return false; } Type_SimpleInput(Category_SimpleInput& p, Params<0>::Type params) : parent(p) { @@ -85,8 +84,8 @@ CycleCheck marker(*this); TRACE_FUNCTION("SimpleInput (init @type)") } - ReturnTuple Dispatch(const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Type_SimpleInput::*)(const ParamTuple&, const ValueTuple&); + ReturnTuple Dispatch(const S& self, const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Type_SimpleInput::*)(const S&, const ParamTuple&, const ValueTuple&); static const CallType Table_SimpleInput[] = { &Type_SimpleInput::Call_stdin, }; @@ -94,76 +93,76 @@ if (label.function_num < 0 || label.function_num >= 1) { FAIL() << "Bad function call " << label; } - return (this->*Table_SimpleInput[label.function_num])(params, args); + return (this->*Table_SimpleInput[label.function_num])(self, 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); + return TypeInstance::Dispatch(self, label, params, args); } + ReturnTuple Call_stdin(const S& self, const ParamTuple& params, const ValueTuple& args); }; -Type_SimpleInput& CreateType(Params<0>::Type params) { - static auto& cached = *new Type_SimpleInput(CreateCategory(), Params<0>::Type()); +S CreateType_SimpleInput(Params<0>::Type params) { + static const auto cached = S_get(new Type_SimpleInput(CreateCategory_SimpleInput(), Params<0>::Type())); return cached; } struct Value_SimpleInput : public TypeValue { - Value_SimpleInput(Type_SimpleInput& p, const ParamTuple& params, const ValueTuple& args) : parent(p) {} - - ReturnTuple Dispatch(const S& self, - const ValueFunction& label, - const ParamTuple& params, const ValueTuple& args) final { - if (args.Size() != label.arg_count) { - FAIL() << "Wrong number of args"; - } - if (params.Size() != label.param_count){ - FAIL() << "Wrong number of params"; - } - if (&label == &Function_BlockReader_readBlock) { - TRACE_FUNCTION("SimpleInput.readBlock") - std::lock_guard lock(mutex); - 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))); + Value_SimpleInput(S p, const ParamTuple& params, const ValueTuple& args) : parent(p) {} + ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { + using CallType = ReturnTuple(Value_SimpleInput::*)(const S&, const ParamTuple&, const ValueTuple&); + static const CallType Table_BlockReader[] = { + &Value_SimpleInput::Call_pastEnd, + &Value_SimpleInput::Call_readBlock, + }; + if (label.collection == Functions_BlockReader) { + if (label.function_num < 0 || label.function_num >= 2) { + FAIL() << "Bad function call " << label; } - } - if (&label == &Function_BlockReader_pastEnd) { - TRACE_FUNCTION("SimpleInput.pastEnd") - std::lock_guard lock(mutex); - return ReturnTuple(Box_Bool(zero_read)); + return (this->*Table_BlockReader[label.function_num])(self, params, args); } return TypeValue::Dispatch(self, label, params, args); } - - std::string CategoryName() const final { return parent.CategoryName(); } + std::string CategoryName() const final { return parent->CategoryName(); } + ReturnTuple Call_pastEnd(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_readBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args); bool zero_read = false; std::mutex mutex; - Type_SimpleInput& parent; + const S parent; }; -S CreateValue(Type_SimpleInput& parent, const ParamTuple& params, const ValueTuple& args) { +S CreateValue_SimpleInput(S parent, const ParamTuple& params, const ValueTuple& args) { return S_get(new Value_SimpleInput(parent, params, args)); } - -const S& Var_stdin = *new S(CreateValue(CreateType(Params<0>::Type()), ParamTuple(), ArgTuple())); - +ReturnTuple Type_SimpleInput::Call_stdin(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("SimpleInput.stdin") + return ReturnTuple(Var_stdin); +} +ReturnTuple Value_SimpleInput::Call_pastEnd(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("SimpleInput.pastEnd") + std::lock_guard lock(mutex); + return ReturnTuple(Box_Bool(zero_read)); +} +ReturnTuple Value_SimpleInput::Call_readBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("SimpleInput.readBlock") + std::lock_guard lock(mutex); + 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))); + } +} +const S& Var_stdin = *new S(CreateValue_SimpleInput(CreateType_SimpleInput(Params<0>::Type()), ParamTuple(), ArgTuple())); } // namespace - TypeCategory& GetCategory_SimpleInput() { - return CreateCategory(); + return CreateCategory_SimpleInput(); } -TypeInstance& GetType_SimpleInput(Params<0>::Type params) { - return CreateType(params); +S GetType_SimpleInput(Params<0>::Type params) { + return CreateType_SimpleInput(params); } - -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -} // namespace ZEOLITE_DYNAMIC_NAMESPACE -using namespace ZEOLITE_DYNAMIC_NAMESPACE; -#endif // ZEOLITE_DYNAMIC_NAMESPACE +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/util/Category_SimpleOutput.cpp b/lib/util/Category_SimpleOutput.cpp --- a/lib/util/Category_SimpleOutput.cpp +++ b/lib/util/Category_SimpleOutput.cpp @@ -1,12 +1,9 @@ /* ----------------------------------------------------------------------------- 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. @@ -16,154 +13,208 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] -// Hand-written implementation of SimpleOutput. - -#include "Category_SimpleOutput.hpp" - #include #include #include "category-source.hpp" +#include "Category_BufferedWriter.hpp" #include "Category_Formatted.hpp" +#include "Category_SimpleOutput.hpp" +#include "Category_String.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 }; - +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE namespace { - extern const S& Var_stdout; extern const S& Var_stderr; extern const S& Var_error; - +const int collection_SimpleOutput = 0; +} // namespace +const void* const Functions_SimpleOutput = &collection_SimpleOutput; +const TypeFunction& Function_SimpleOutput_error = (*new TypeFunction{ 0, 0, 1, "SimpleOutput", "error", Functions_SimpleOutput, 0 }); +const TypeFunction& Function_SimpleOutput_stderr = (*new TypeFunction{ 0, 0, 1, "SimpleOutput", "stderr", Functions_SimpleOutput, 1 }); +const TypeFunction& Function_SimpleOutput_stdout = (*new TypeFunction{ 0, 0, 1, "SimpleOutput", "stdout", Functions_SimpleOutput, 2 }); +namespace { +class Category_SimpleOutput; +class Type_SimpleOutput; +S CreateType_SimpleOutput(Params<0>::Type params); +class Value_SimpleOutput; +class Writer; +S CreateValue_SimpleOutput(S writer); struct Category_SimpleOutput : public TypeCategory { std::string CategoryName() const final { return "SimpleOutput"; } + Category_SimpleOutput() { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("SimpleOutput (init @category)") + } + ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Category_SimpleOutput::*)(const ParamTuple&, const ValueTuple&); + return TypeCategory::Dispatch(label, params, args); + } }; - +Category_SimpleOutput& CreateCategory_SimpleOutput() { + static auto& category = *new Category_SimpleOutput(); + return category; +} 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"; + std::string CategoryName() const final { return parent.CategoryName(); } + void BuildTypeName(std::ostream& output) const final { + return TypeInstance::TypeNameFrom(output, parent); + } + Category_SimpleOutput& parent; + bool CanConvertFrom(const S& from) const final { + std::vector> args; + if (!from->TypeArgsForParent(parent, args)) return false; + if(args.size() != 0) { + FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); } - if (params.Size() != label.param_count){ - FAIL() << "Wrong number of params"; + return true; + } + bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { + if (&category == &GetCategory_SimpleOutput()) { + args = std::vector>{}; + return true; } - if (&label == &Function_SimpleOutput_stdout) { - return ReturnTuple(Var_stdout); + if (&category == &GetCategory_BufferedWriter()) { + args = std::vector>{GetType_Formatted(T_get())}; + return true; } - if (&label == &Function_SimpleOutput_stderr) { - return ReturnTuple(Var_stderr); + if (&category == &GetCategory_Writer()) { + args = std::vector>{GetType_Formatted(T_get())}; + return true; } - if (&label == &Function_SimpleOutput_error) { - return ReturnTuple(Var_error); + return false; + } + Type_SimpleOutput(Category_SimpleOutput& p, Params<0>::Type params) : parent(p) { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("SimpleOutput (init @type)") + } + ReturnTuple Dispatch(const S& self, const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Type_SimpleOutput::*)(const S&, const ParamTuple&, const ValueTuple&); + static const CallType Table_SimpleOutput[] = { + &Type_SimpleOutput::Call_error, + &Type_SimpleOutput::Call_stderr, + &Type_SimpleOutput::Call_stdout, + }; + if (label.collection == Functions_SimpleOutput) { + if (label.function_num < 0 || label.function_num >= 3) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_SimpleOutput[label.function_num])(self, params, args); } - return TypeInstance::Dispatch(label, params, args); + return TypeInstance::Dispatch(self, label, params, args); } + ReturnTuple Call_error(const S& self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_stderr(const S& self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_stdout(const S& self, const ParamTuple& params, const ValueTuple& args); }; - -class Value_SimpleOutput : public TypeValue { - public: - Value_SimpleOutput(std::ostream& output) : output_(output) {} - - std::string CategoryName() const final { return "SimpleOutput"; } - - ReturnTuple Dispatch(const S& self, - const ValueFunction& label, - const ParamTuple& params, const ValueTuple& args) final { - if (args.Size() != label.arg_count) { - FAIL() << "Wrong number of args"; - } - if (params.Size() != label.param_count){ - FAIL() << "Wrong number of params"; - } - if (&label == &Function_Writer_write) { - TRACE_FUNCTION("SimpleOutput.write") - std::lock_guard lock(mutex_); - output_ << TypeValue::Call(args.At(0), Function_Formatted_formatted, - ParamTuple(), ArgTuple()).Only()->AsString(); - return ReturnTuple(); +S CreateType_SimpleOutput(Params<0>::Type params) { + static const auto cached = S_get(new Type_SimpleOutput(CreateCategory_SimpleOutput(), Params<0>::Type())); + return cached; +} +struct Writer { + virtual void Write(const PrimString& message) = 0; + virtual void Flush() = 0; + virtual ~Writer() {} +}; +struct Value_SimpleOutput : public TypeValue { + Value_SimpleOutput(S w) : writer_(w) {} + ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { + using CallType = ReturnTuple(Value_SimpleOutput::*)(const S&, const ParamTuple&, const ValueTuple&); + static const CallType Table_BufferedWriter[] = { + &Value_SimpleOutput::Call_flush, + }; + static const CallType Table_Writer[] = { + &Value_SimpleOutput::Call_write, + }; + if (label.collection == Functions_BufferedWriter) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_BufferedWriter[label.function_num])(self, params, args); } - if (&label == &Function_BufferedWriter_flush) { - return ReturnTuple(); + if (label.collection == Functions_Writer) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_Writer[label.function_num])(self, params, args); } return TypeValue::Dispatch(self, label, params, args); } - - private: + std::string CategoryName() const final { return "SimpleOutput"; } + ReturnTuple Call_flush(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_write(const S& Var_self, const ParamTuple& params, const ValueTuple& args); std::mutex mutex_; - std::ostream& output_; + const S writer_; }; - -class Value_SimpleError : public TypeValue { +S CreateValue_SimpleOutput(S writer) { + return S_get(new Value_SimpleOutput(writer)); +} +ReturnTuple Type_SimpleOutput::Call_error(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("SimpleOutput.error") + return ReturnTuple(Var_error); +} +ReturnTuple Type_SimpleOutput::Call_stderr(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("SimpleOutput.stderr") + return ReturnTuple(Var_stderr); +} +ReturnTuple Type_SimpleOutput::Call_stdout(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("SimpleOutput.stdout") + return ReturnTuple(Var_stdout); +} +ReturnTuple Value_SimpleOutput::Call_flush(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("SimpleOutput.flush"); + std::lock_guard lock(mutex_); + writer_->Flush(); + return ReturnTuple(); +} +ReturnTuple Value_SimpleOutput::Call_write(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("SimpleOutput.write") + const S& Var_arg1 = (args.At(0)); + std::lock_guard lock(mutex_); + writer_->Write(TypeValue::Call(args.At(0), Function_Formatted_formatted, + ParamTuple(), ArgTuple()).Only()->AsString()); + return ReturnTuple(); +} +class StreamWriter : public Writer { public: - std::string CategoryName() const final { return "SimpleError"; } + StreamWriter(std::ostream& output) : output_(output) {} - ReturnTuple Dispatch(const S& self, - const ValueFunction& label, - const ParamTuple& params, const ValueTuple& args) final { - if (args.Size() != label.arg_count) { - FAIL() << "Wrong number of args"; - } - if (params.Size() != label.param_count){ - FAIL() << "Wrong number of params"; - } - if (&label == &Function_Writer_write) { - TRACE_FUNCTION("SimpleOutput.write") - std::lock_guard lock(mutex_); - output_ << TypeValue::Call(args.At(0), Function_Formatted_formatted, - ParamTuple(), ArgTuple()).Only()->AsString(); - return ReturnTuple(); - } - if (&label == &Function_BufferedWriter_flush) { - TRACE_FUNCTION("SimpleOutput.flush") - std::lock_guard lock(mutex_); - FAIL() << output_.str(); - return ReturnTuple(); - } - return TypeValue::Dispatch(self, label, params, args); + void Write(const PrimString& message) final { + output_ << message; } + void Flush() final {} + private: - std::mutex mutex_; - std::ostringstream output_; + std::ostream& output_; }; +class ErrorWriter : public Writer { + public: + void Write(const PrimString& message) final { + output_ << message; + } -const S& Var_stdout = *new S(new Value_SimpleOutput(std::cout)); -const S& Var_stderr = *new S(new Value_SimpleOutput(std::cerr)); -const S& Var_error = *new S(new Value_SimpleError()); + void Flush() final { + FAIL() << output_.str(); + } + std::ostringstream output_; +}; +const S& Var_stdout = CreateValue_SimpleOutput(S_get(new StreamWriter(std::cout))); +const S& Var_stderr = CreateValue_SimpleOutput(S_get(new StreamWriter(std::cerr))); +const S& Var_error = CreateValue_SimpleOutput(S_get(new ErrorWriter())); } // namespace - TypeCategory& GetCategory_SimpleOutput() { - static auto& category = *new Category_SimpleOutput(); - return category; + return CreateCategory_SimpleOutput(); } - -TypeInstance& GetType_SimpleOutput(Params<0>::Type) { - static auto& instance = *new Type_SimpleOutput(); - return instance; +S GetType_SimpleOutput(Params<0>::Type params) { + return CreateType_SimpleOutput(params); } - -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -} // namespace ZEOLITE_DYNAMIC_NAMESPACE -#endif // ZEOLITE_DYNAMIC_NAMESPACE +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/util/tests.0rt b/lib/util/tests.0rt --- a/lib/util/tests.0rt +++ b/lib/util/tests.0rt @@ -17,14 +17,14 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "stdout writer" { - success Test$run() + success Test.run() require stdout "message" exclude stderr "message" } define Test { run () { - \ LazyStream$new().append("message").writeTo(SimpleOutput$stdout()) + \ LazyStream.new().append("message").writeTo(SimpleOutput.stdout()) } } @@ -34,14 +34,14 @@ testcase "stderr writer" { - success Test$run() + success Test.run() require stderr "message" exclude stdout "message" } define Test { run () { - \ LazyStream$new().append("message").writeTo(SimpleOutput$stderr()) + \ LazyStream.new().append("message").writeTo(SimpleOutput.stderr()) } } @@ -51,13 +51,13 @@ testcase "error writer" { - crash Test$run() + crash Test.run() require "message" } define Test { run () { - \ LazyStream$new().append("message").writeTo(SimpleOutput$error()) + \ LazyStream.new().append("message").writeTo(SimpleOutput.error()) } } @@ -67,7 +67,7 @@ testcase "iterate String forward" { - success Test$run() + success Test.run() } define Test { @@ -75,7 +75,7 @@ String s <- "abcde" Int count <- 0 scoped { - ReadIterator iter <- ReadIterator$$fromReadPosition(s) + ReadIterator iter <- ReadIterator:fromReadPosition(s) } in while (!iter.pastForwardEnd()) { if (iter.readCurrent() != s.readPosition(count)) { fail(iter.readCurrent()) @@ -96,7 +96,7 @@ testcase "iterate String reverse" { - success Test$run() + success Test.run() } define Test { @@ -104,7 +104,7 @@ String s <- "abcde" Int count <- s.readSize()-1 scoped { - ReadIterator iter <- ReadIterator$$fromReadPositionAt(s,count) + ReadIterator iter <- ReadIterator:fromReadPositionAt(s,count) } in while (!iter.pastReverseEnd()) { if (iter.readCurrent() != s.readPosition(count)) { fail(iter.readCurrent()) @@ -125,21 +125,21 @@ testcase "Argv is set and available" { - success Test$run() + success Test.run() require stdout "/testcase$" } define Test { run () { - Int count <- Argv$global().readSize() + Int count <- Argv.global().readSize() if (count != 1) { fail(count) } - String name <- Argv$global().readPosition(0) - \ LazyStream$new() + String name <- Argv.global().readPosition(0) + \ LazyStream.new() .append(name) .append("\n") - .writeTo(SimpleOutput$stdout()) + .writeTo(SimpleOutput.stdout()) } } @@ -148,8 +148,49 @@ } +testcase "Argv subSequence" { + success Test.run() + require stdout "/testcase$" +} + +define Test { + run () { + ReadPosition argv <- Argv.global().subSequence(0,1) + Int count <- argv.readSize() + if (count != 1) { + fail(count) + } + String name <- argv.readPosition(0) + \ LazyStream.new() + .append(name) + .append("\n") + .writeTo(SimpleOutput.stdout()) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "Argv subSequence out of bounds" { + crash Test.run() + require "position 5" +} + +define Test { + run () { + ReadPosition argv <- Argv.global().subSequence(5,1) + } +} + +concrete Test { + @type run () -> () +} + + testcase "TextReader splits lines correctly" { - success Test$run() + success Test.run() } concrete FakeFile { @@ -188,7 +229,7 @@ define Test { run () { - TextReader reader <- TextReader$fromBlockReader(FakeFile$create()) + TextReader reader <- TextReader.fromBlockReader(FakeFile.create()) \ checkNext(reader,"this is a partial line") \ checkNext(reader,"with some more data") \ checkNext(reader,"and") @@ -220,7 +261,7 @@ testcase "TextReader readAll" { - success Test$run() + success Test.run() } concrete FakeFile { @@ -259,8 +300,8 @@ define Test { run () { - String allContents <- TextReader$readAll(FakeFile$create()) - \ Testing$check(allContents,"this is a partial line\nwith some more data\nand\nmore lines\nunfinished") + String allContents <- TextReader.readAll(FakeFile.create()) + \ Testing.check(allContents,"this is a partial line\nwith some more data\nand\nmore lines\nunfinished") } } @@ -270,16 +311,16 @@ testcase "ErrorOr value" { - success Test$run() + success Test.run() } define Test { run () { - ErrorOr value <- ErrorOr$$value(10) + ErrorOr value <- ErrorOr:value(10) if (value.isError()) { fail("Failed") } - \ Testing$check(value.getValue(),10) + \ Testing.check(value.getValue(),10) } } @@ -289,13 +330,13 @@ testcase "ErrorOr getError() crashes with value" { - crash Test$run() + crash Test.run() require "empty" } define Test { run () { - ErrorOr value <- ErrorOr$$value(10) + ErrorOr value <- ErrorOr:value(10) \ value.getError() } } @@ -306,16 +347,16 @@ testcase "ErrorOr error" { - success Test$run() + success Test.run() } define Test { run () { - ErrorOr value <- ErrorOr$$error("error message") + ErrorOr value <- ErrorOr:error("error message") if (!value.isError()) { fail("Failed") } - \ Testing$check(value.getError().formatted(),"error message") + \ Testing.check(value.getError().formatted(),"error message") } } @@ -325,13 +366,13 @@ testcase "ErrorOr getValue() crashes with error" { - crash Test$run() + crash Test.run() require "error message" } define Test { run () { - ErrorOr value <- ErrorOr$$error("error message") + ErrorOr value <- ErrorOr:error("error message") \ value.getValue() } } @@ -342,15 +383,15 @@ testcase "ErrorOr convert error" { - success Test$run() + success Test.run() } define Test { run () { scoped { - ErrorOr error <- ErrorOr$$error("error message") + ErrorOr error <- ErrorOr:error("error message") } in ErrorOr value <- error.convertError() - \ Testing$check(value.getError().formatted(),"error message") + \ Testing.check(value.getError().formatted(),"error message") } } diff --git a/lib/util/util.0rp b/lib/util/util.0rp --- a/lib/util/util.0rp +++ b/lib/util/util.0rp @@ -67,12 +67,16 @@ } concrete SimpleOutput { + refines BufferedWriter + @type stdout () -> (BufferedWriter) @type stderr () -> (BufferedWriter) @type error () -> (BufferedWriter) } concrete SimpleInput { + refines BlockReader + @type stdin () -> (BlockReader) } diff --git a/lib/util/util.0rx b/lib/util/util.0rx --- a/lib/util/util.0rx +++ b/lib/util/util.0rx @@ -57,11 +57,11 @@ readCurrent () { if (pastForwardEnd() || pastReverseEnd()) { - \ LazyStream$new() + \ LazyStream.new() .append("Position ") .append(position) .append(" is out of bounds") - .writeTo(SimpleOutput$error()) + .writeTo(SimpleOutput.error()) } return reader.readPosition(position) } @@ -120,7 +120,7 @@ } readAll (reader) { - Builder builder <- String$builder() + Builder builder <- String.builder() while (!reader.pastEnd()) { \ builder.append(reader.readBlock($ExprLookup[BLOCK_READ_SIZE]$)) } diff --git a/src/Base/CompileError.hs b/src/Base/CompileError.hs --- a/src/Base/CompileError.hs +++ b/src/Base/CompileError.hs @@ -24,7 +24,13 @@ CompileErrorM(..), (), + (), + collectAllM_, + collectFirstM_, errorFromIO, + isCompileErrorM, + isCompileSuccessM, mapErrorsM, mapErrorsM_, ) where @@ -46,10 +52,13 @@ class Monad m => CompileErrorM m where #endif compileErrorM :: String -> m a - 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 + collectAllM :: Foldable f => f (m a) -> m [a] + collectAnyM :: Foldable f => f (m a) -> m [a] + collectFirstM :: Foldable f => f (m a) -> m a + withContextM :: m a -> String -> m a + withContextM c _ = c + summarizeErrorsM :: m a -> String -> m a + summarizeErrorsM e _ = e compileWarningM :: String -> m () compileWarningM _ = return () compileBackgroundM :: String -> m () @@ -58,16 +67,34 @@ resetBackgroundM = id ( m a -> String -> m a -() :: CompileErrorM m => String -> m a -> m a -(??>) = flip reviseErrorM +(??>) = flip withContextM +( m a -> String -> m a +() :: CompileErrorM m => String -> m a -> m a +(!!>) = flip summarizeErrorsM + +collectAllM_ :: (Foldable f, CompileErrorM m) => f (m a) -> m () +collectAllM_ = fmap (const ()) . collectAllM + +collectFirstM_ :: (Foldable f, CompileErrorM m) => f (m a) -> m () +collectFirstM_ = fmap (const ()) . collectFirstM + mapErrorsM :: CompileErrorM m => (a -> m b) -> [a] -> m [b] -mapErrorsM f = collectAllOrErrorM . map f +mapErrorsM f = collectAllM . map f mapErrorsM_ :: CompileErrorM m => (a -> m b) -> [a] -> m () -mapErrorsM_ f xs = mapErrorsM f xs >> return () +mapErrorsM_ f = collectAllM_ . map f + +isCompileErrorM :: CompileErrorM m => m a -> m Bool +isCompileErrorM x = collectFirstM [x >> return False,return True] + +isCompileSuccessM :: CompileErrorM m => m a -> m Bool +isCompileSuccessM x = collectFirstM [x >> return True,return False] errorFromIO :: (MonadIO m, CompileErrorM m) => IO a -> m a errorFromIO x = do diff --git a/src/Base/CompileInfo.hs b/src/Base/CompileInfo.hs --- a/src/Base/CompileInfo.hs +++ b/src/Base/CompileInfo.hs @@ -24,6 +24,8 @@ CompileInfo, CompileInfoIO, CompileMessage, + asCompileError, + asCompileWarnings, fromCompileInfo, getCompileError, getCompileErrorT, @@ -33,12 +35,12 @@ getCompileWarningsT, isCompileError, isCompileErrorT, + isEmptyCompileMessage, toCompileInfo, tryCompileInfoIO, ) where import Control.Applicative -import Control.Monad ((>=>)) import Control.Monad.IO.Class () import Control.Monad.Trans import Data.Foldable @@ -56,7 +58,6 @@ #endif import Base.CompileError -import Base.Mergeable type CompileInfo a = CompileInfoT Identity a @@ -74,7 +75,7 @@ getCompileSuccess :: CompileInfo a -> a getCompileSuccess = runIdentity . getCompileSuccessT -getCompileWarnings :: CompileInfo a -> [String] +getCompileWarnings :: CompileInfo a -> CompileMessage getCompileWarnings = runIdentity . getCompileWarningsT isCompileError :: CompileInfo a -> Bool @@ -86,7 +87,7 @@ getCompileSuccessT :: Monad m => CompileInfoT m a -> m a getCompileSuccessT = fmap csData . citState -getCompileWarningsT :: Monad m => CompileInfoT m a -> m [String] +getCompileWarningsT :: Monad m => CompileInfoT m a -> m CompileMessage getCompileWarningsT = fmap getWarnings . citState isCompileErrorT :: Monad m => CompileInfoT m a -> m Bool @@ -96,27 +97,48 @@ CompileFail _ _ -> return True _ -> return False +isEmptyCompileMessage :: CompileMessage -> Bool +isEmptyCompileMessage (CompileMessage "" ws) = all isEmptyCompileMessage ws +isEmptyCompileMessage _ = False + fromCompileInfo :: Monad m => CompileInfo a -> CompileInfoT m a fromCompileInfo x = runIdentity $ do x' <- citState x return $ CompileInfoT $ return x' +asCompileWarnings :: Monad m => CompileInfo a -> CompileInfoT m () +asCompileWarnings x = runIdentity $ do + x' <- citState x + return $ CompileInfoT $ return $ + case x' of + (CompileFail ws es) -> CompileSuccess (ws `mergeMessages` es) [] () + (CompileSuccess ws bs _) -> CompileSuccess ws bs () + +asCompileError :: Monad m => CompileInfo a -> CompileInfoT m () +asCompileError x = runIdentity $ do + x' <- citState x + return $ CompileInfoT $ return $ + case x' of + (CompileSuccess ws bs _) -> includeBackground bs $ CompileFail emptyMessage ws + (CompileFail ws es) -> CompileFail ws es + toCompileInfo :: Monad m => CompileInfoT m a -> m (CompileInfo a) toCompileInfo x = do x' <- citState x return $ CompileInfoT $ return x' -tryCompileInfoIO :: String -> CompileInfoIO a -> IO a -tryCompileInfoIO message x = do - x' <- toCompileInfo $ x `reviseErrorM` message - let warnings = map (\w -> "Warning: " ++ w ++ "\n") (getCompileWarnings x') +tryCompileInfoIO :: String -> String -> CompileInfoIO a -> IO a +tryCompileInfoIO warn err x = do + x' <- toCompileInfo x + let w = getCompileWarnings $ x' Show (CompileInfoState a) where + show = format where + format (CompileFail w e) = intercalate "\n" $ errors ++ warnings where + errors = showAs "Errors:" $ lines $ show e + warnings = showAs "Warnings:" $ lines $ show w + format (CompileSuccess w b x) = intercalate "\n" $ content ++ warnings ++ background where + content = [show x] + warnings = showAs "Warnings:" $ lines $ show w + background = showAs "Background:" b + showAs m = (m:) . map (" " ++) + +instance Show a => Show (CompileInfo a) where + show = show . runIdentity . citState + instance (Functor m, Monad m) => Functor (CompileInfoT m) where fmap f x = CompileInfoT $ do x' <- citState x @@ -152,7 +188,7 @@ CompileSuccess w b d -> return $ CompileSuccess w b (f d) instance (Applicative m, Monad m) => Applicative (CompileInfoT m) where - pure = CompileInfoT .return . CompileSuccess [] [] + pure = CompileInfoT .return . CompileSuccess emptyMessage [] f <*> x = CompileInfoT $ do f' <- citState f x' <- citState x @@ -160,9 +196,9 @@ (CompileFail w e,_) -> return $ CompileFail w e -- Not the same a. (i,CompileFail w e) -> - return $ CompileFail (getWarnings i ++ w) (addBackground (getBackground i) e) + return $ CompileFail (getWarnings i `mergeMessages` w) (addBackground (getBackground i) e) (CompileSuccess w1 b1 f2,CompileSuccess w2 b2 d) -> - return $ CompileSuccess (w1 ++ w2) (b1 ++ b2) (f2 d) + return $ CompileSuccess (w1 `mergeMessages` w2) (b1 ++ b2) (f2 d) instance Monad m => Monad (CompileInfoT m) where x >>= f = CompileInfoT $ do @@ -171,7 +207,7 @@ CompileFail w e -> return $ CompileFail w e -- Not the same a. CompileSuccess w b d -> do d2 <- citState $ f d - return $ includeBackground b $ prependWarning w d2 + return $ includeBackground b $ includeWarnings w d2 return = pure #if MIN_VERSION_base(4,9,0) @@ -180,54 +216,75 @@ #endif instance MonadTrans CompileInfoT where - lift = CompileInfoT . fmap (CompileSuccess [] []) + lift = CompileInfoT . fmap (CompileSuccess emptyMessage []) instance MonadIO m => MonadIO (CompileInfoT m) where liftIO = lift . liftIO instance Monad m => CompileErrorM (CompileInfoT m) where - compileErrorM e = CompileInfoT (return $ CompileFail [] $ CompileMessage e []) - collectAllOrErrorM xs = CompileInfoT $ do - xs' <- sequence $ map citState $ foldr (:) [] xs - return $ result $ splitErrorsAndData xs' where - result ([],xs2,bs,ws) = CompileSuccess ws bs xs2 - result (es,_,bs,ws) = CompileFail ws $ addBackground bs $ CompileMessage "" es - collectOneOrErrorM xs = CompileInfoT $ do - xs' <- sequence $ map citState $ foldr (:) [] xs - return $ result $ splitErrorsAndData xs' where - result (_,x:_,bs,ws) = CompileSuccess ws bs x - result ([],_,bs,ws) = CompileFail ws $ addBackground bs $ CompileMessage "" [] - result (es,_,bs,ws) = CompileFail ws $ addBackground bs $ CompileMessage "" es - reviseErrorM x e2 = CompileInfoT $ do + compileErrorM e = CompileInfoT $ return $ CompileFail emptyMessage $ CompileMessage e [] + collectAllM = combineResults (select . splitErrorsAndData) where + select ([],xs2,bs,ws) = CompileSuccess (CompileMessage "" ws) bs xs2 + select (es,_,bs,ws) = CompileFail (CompileMessage "" ws) $ addBackground bs $ CompileMessage "" es + collectAnyM = combineResults (select . splitErrorsAndData) where + select (_,xs2,bs,ws) = CompileSuccess (CompileMessage "" ws) bs xs2 + collectFirstM = combineResults (select . splitErrorsAndData) where + select (_,x:_,bs,ws) = CompileSuccess (CompileMessage "" ws) bs x + select (es,_,bs,ws) = CompileFail (CompileMessage "" ws) $ addBackground bs $ CompileMessage "" es + withContextM x c = CompileInfoT $ do x' <- citState x case x' of - CompileFail w (CompileMessage [] ms) -> return $ CompileFail w $ CompileMessage e2 ms - CompileFail w e -> return $ CompileFail w $ CompileMessage e2 [e] - x2 -> return x2 - compileWarningM w = CompileInfoT (return $ CompileSuccess [w] [] ()) - compileBackgroundM b = CompileInfoT (return $ CompileSuccess [] [b] ()) + CompileFail w e -> return $ CompileFail (pushWarningScope c w) (pushErrorScope c e) + CompileSuccess w bs x2 -> return $ CompileSuccess (pushWarningScope c w) bs x2 + summarizeErrorsM x e2 = CompileInfoT $ do + x' <- citState x + case x' of + CompileFail w e -> return $ CompileFail w (pushErrorScope e2 e) + x2 -> return x2 + compileWarningM w = CompileInfoT (return $ CompileSuccess (CompileMessage w []) [] ()) + compileBackgroundM b = CompileInfoT (return $ CompileSuccess emptyMessage [b] ()) resetBackgroundM x = CompileInfoT $ do x' <- citState x case x' of CompileSuccess w _ d -> return $ CompileSuccess w [] d x2 -> return x2 -instance Monad m => MergeableM (CompileInfoT m) where - mergeAnyM xs = CompileInfoT $ do - xs' <- sequence $ map citState $ foldr (:) [] xs - return $ result $ splitErrorsAndData xs' where - result ([],[],bs,ws) = CompileFail ws $ addBackground bs $ CompileMessage "" [] - result (es,[],bs,ws) = CompileFail ws $ addBackground bs $ CompileMessage "" es - result (_,xs2,bs,ws) = CompileSuccess ws bs (mergeAny xs2) - mergeAllM = collectAllOrErrorM >=> return . mergeAll +combineResults :: (Monad m, Foldable f) => + ([CompileInfoState a] -> CompileInfoState b) -> f (CompileInfoT m a) -> CompileInfoT m b +combineResults f = CompileInfoT . fmap f . sequence . map citState . foldr (:) [] -getWarnings :: CompileInfoState a -> [String] +emptyMessage :: CompileMessage +emptyMessage = CompileMessage "" [] + +pushErrorScope :: String -> CompileMessage -> CompileMessage +pushErrorScope e2 ea@(CompileMessage e ms) + | null e = CompileMessage e2 ms + | otherwise = CompileMessage e2 [ea] + +pushWarningScope :: String -> CompileMessage -> CompileMessage +pushWarningScope e2 ea + | isEmptyCompileMessage ea = emptyMessage -- Skip the scope if there isn't already a warning. + | otherwise = pushErrorScope e2 ea + +mergeMessages :: CompileMessage -> CompileMessage -> CompileMessage +mergeMessages (CompileMessage "" []) e2 = e2 +mergeMessages e1 (CompileMessage "" []) = e1 +mergeMessages (CompileMessage "" es1) (CompileMessage "" es2) = CompileMessage "" (es1 ++ es2) +mergeMessages e1 (CompileMessage "" es2) = CompileMessage "" ([e1] ++ es2) +mergeMessages (CompileMessage "" es1) e2 = CompileMessage "" (es1 ++ [e2]) +mergeMessages e1 e2 = CompileMessage "" [e1,e2] + +addBackground :: [String] -> CompileMessage -> CompileMessage +addBackground b (CompileMessage e es) = CompileMessage e (es ++ map (flip CompileMessage []) b) + +getWarnings :: CompileInfoState a -> CompileMessage getWarnings (CompileFail w _) = w getWarnings (CompileSuccess w _ _) = w -prependWarning :: [String] -> CompileInfoState a -> CompileInfoState a -prependWarning w (CompileSuccess w2 b d) = CompileSuccess (w ++ w2) b d -prependWarning w (CompileFail w2 e) = CompileFail (w ++ w2) e +includeWarnings :: CompileMessage -> CompileInfoState a -> CompileInfoState a +includeWarnings = update where + update w (CompileSuccess w2 b d) = CompileSuccess (w `mergeMessages` w2) b d + update w (CompileFail w2 e) = CompileFail (w `mergeMessages` w2) e getBackground :: CompileInfoState a -> [String] getBackground (CompileSuccess _ b _) = b @@ -237,10 +294,7 @@ includeBackground b (CompileFail w e) = CompileFail w (addBackground b e) includeBackground b1 (CompileSuccess w b2 d) = CompileSuccess w (b1 ++ b2) d -addBackground :: [String] -> CompileMessage -> CompileMessage -addBackground b (CompileMessage e es) = CompileMessage e (es ++ map (flip CompileMessage []) b) - -splitErrorsAndData :: Foldable f => f (CompileInfoState a) -> ([CompileMessage],[a],[String],[String]) +splitErrorsAndData :: Foldable f => f (CompileInfoState a) -> ([CompileMessage],[a],[String],[CompileMessage]) splitErrorsAndData = foldr partition ([],[],[],[]) where - partition (CompileFail w e) (es,ds,bs,ws) = (e:es,ds,bs,w++ws) - partition (CompileSuccess w b d) (es,ds,bs,ws) = (es,d:ds,b++bs,w++ws) + partition (CompileFail w e) (es,ds,bs,ws) = (e:es,ds,bs,w:ws) + partition (CompileSuccess w b d) (es,ds,bs,ws) = (es,d:ds,b++bs,w:ws) diff --git a/src/Base/MergeTree.hs b/src/Base/MergeTree.hs --- a/src/Base/MergeTree.hs +++ b/src/Base/MergeTree.hs @@ -17,16 +17,21 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com] {-# LANGUAGE Safe #-} +{-# LANGUAGE TypeFamilies #-} module Base.MergeTree ( MergeTree, + matchOnlyLeaf, + mergeAllM, + mergeAnyM, mergeLeaf, - pruneMergeTree, + pairMergeTree, reduceMergeTree, ) where -import Data.Functor.Identity (runIdentity) +import Data.List (intercalate) +import Base.CompileError import Base.Mergeable @@ -36,40 +41,79 @@ MergeLeaf a deriving (Eq) -instance Show a => Show (MergeTree a) where - show (MergeAny xs) = "mergeAny " ++ show xs - show (MergeAll xs) = "mergeAll " ++ show xs - show (MergeLeaf x) = "mergeLeaf " ++ show x - mergeLeaf :: a -> MergeTree a mergeLeaf = MergeLeaf -reduceMergeTree :: (Mergeable b, MergeableM m) => (b -> m b) -> (b -> m b) -> - (a -> m b) -> MergeTree a -> m b -reduceMergeTree anyOp allOp leafOp xa = reduce xa where - reduce (MergeAny xs) = do - xs' <- mergeAnyM $ map reduce xs - anyOp xs' - reduce (MergeAll xs) = do - xs' <- mergeAllM $ map reduce xs - allOp xs' +instance Show a => Show (MergeTree a) where + show = reduceMergeCommon anyOp allOp leafOp where + anyOp xs = "mergeAny [" ++ intercalate "," xs ++ "]" + allOp xs = "mergeAll [" ++ intercalate "," xs ++ "]" + leafOp x = "mergeLeaf " ++ show x + +instance PreserveMerge (MergeTree a) where + type T (MergeTree a) = a + convertMerge = reduceMergeCommon mergeAny mergeAll + +reduceMergeTree :: PreserveMerge a => ([b] -> b) -> ([b] -> b) -> (T a -> b) -> a -> b +reduceMergeTree anyOp allOp leafOp = reduceMergeCommon anyOp allOp leafOp . toMergeTree + +toMergeTree :: PreserveMerge a => a -> MergeTree (T a) +toMergeTree = convertMerge mergeLeaf + +reduceMergeCommon :: ([b] -> b) -> ([b] -> b) -> (a -> b) -> MergeTree a -> b +reduceMergeCommon anyOp allOp leafOp = reduce where + reduce (MergeAny xs) = anyOp $ map reduce xs + reduce (MergeAll xs) = allOp $ map reduce xs reduce (MergeLeaf x) = leafOp x -pruneMergeTree :: MergeableM m => MergeTree (m a) -> m (MergeTree a) -pruneMergeTree = reduceMergeTree return return (fmap MergeLeaf) +pairMergeTree :: (PreserveMerge a, PreserveMerge b) => + ([c] -> c) -> ([c] -> c) -> (T a -> T b -> c) -> a -> b -> c +pairMergeTree anyOp allOp leafOp x y = pair (toMergeTree x) (toMergeTree y) where + pair (MergeLeaf x2) (MergeLeaf y2) = x2 `leafOp` y2 + pair x2@(MergeAll xs) y2@(MergeAny ys) = + anyOp $ leafComp ++ leftComp ++ rightComp where + (xs2,xl) = separateLeaves xs + (ys2,yl) = separateLeaves ys + -- Non-leaves need the entire other side available. + leftComp = map (`pair` y2) xs2 + rightComp = map (x2 `pair`) ys2 + -- Leaves can be expanded either side first. + leafComp = do + xx <- xl + yy <- yl + [xx `leafOp` yy] + -- NOTE: allOp is expanded first so that anyOp is ignored when either both + -- sides are minBound or both sides are maxBound. This allows + -- pairMergeTree mergeAny mergeAll (==) to be a partial order. + pair (MergeAny xs) y2 = allOp $ map (`pair` y2) xs + pair x2 (MergeAll ys) = allOp $ map (x2 `pair`) ys + pair (MergeAll xs) y2 = anyOp $ map (`pair` y2) xs + pair x2 (MergeAny ys) = anyOp $ map (x2 `pair`) ys +separateLeaves :: [MergeTree a] -> ([MergeTree a],[a]) +separateLeaves = foldr split ([],[]) where + split (MergeLeaf x) (ms,ls) = (ms,x:ls) + split x (ms,ls) = (x:ms,ls) + instance Functor MergeTree where - fmap f (MergeAny xs) = MergeAny (map (fmap f) xs) - fmap f (MergeAll xs) = MergeAll (map (fmap f) xs) - fmap f (MergeLeaf x) = MergeLeaf (f x) + fmap f = reduceMergeCommon mergeAny mergeAll (mergeLeaf . f) +instance Applicative MergeTree where + pure = mergeLeaf + f <*> x = reduceMergeCommon mergeAny mergeAll (<$> x) f + +instance Monad MergeTree where + return = pure + x >>= f = reduceMergeCommon mergeAny mergeAll f x + instance Foldable MergeTree where - foldr f y = foldr f y . runIdentity . reduceMergeTree return return (return . (:[])) + foldr f y = foldr f y . reduceMergeCommon concat concat (:[]) instance Traversable MergeTree where - traverse f (MergeAny xs) = MergeAny <$> foldr (<*>) (pure []) (map (fmap (:) . traverse f) xs) - traverse f (MergeAll xs) = MergeAll <$> foldr (<*>) (pure []) (map (fmap (:) . traverse f) xs) - traverse f (MergeLeaf x) = fmap MergeLeaf (f x) + traverse f = reduceMergeCommon anyOp allOp leafOp where + anyOp = (mergeAny <$>) . foldr (<*>) (pure []) . (map (fmap (:))) + allOp = (mergeAll <$>) . foldr (<*>) (pure []) . (map (fmap (:))) + leafOp = (mergeLeaf <$>) . f instance Mergeable (MergeTree a) where mergeAny = unnest . foldr ((++) . flattenAny) [] where @@ -82,3 +126,18 @@ flattenAll x = [x] unnest [x] = x unnest xs = MergeAll xs + +instance Bounded (MergeTree a) where + minBound = mergeAny Nothing + maxBound = mergeAll Nothing + +mergeAnyM :: (PreserveMerge a, CompileErrorM m) => [m a] -> m a +mergeAnyM xs = do + collectFirstM_ xs + fmap mergeAny $ collectAnyM xs + +mergeAllM :: (PreserveMerge a, CompileErrorM m) => [m a] -> m a +mergeAllM = fmap mergeAll . collectAllM + +matchOnlyLeaf :: (PreserveMerge a, CompileErrorM m) => a -> m (T a) +matchOnlyLeaf = reduceMergeTree (const $ compileErrorM "") (const $ compileErrorM "") return diff --git a/src/Base/Mergeable.hs b/src/Base/Mergeable.hs --- a/src/Base/Mergeable.hs +++ b/src/Base/Mergeable.hs @@ -16,56 +16,30 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com] -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Safe #-} +{-# LANGUAGE TypeFamilies #-} module Base.Mergeable ( Mergeable(..), - MergeableM(..), - mergeDefault, - mergeDefaultM, + PreserveMerge(..), ) where -import Data.Functor.Identity import Data.Map as Map hiding (foldr) -#if MIN_VERSION_base(4,11,0) -#else -import Data.Monoid ((<>)) -#endif - class Mergeable a where mergeAny :: Foldable f => f a -> a mergeAll :: Foldable f => f a -> a -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 - -mergeDefault :: Mergeable a => a -mergeDefault = mergeAll Nothing - -mergeDefaultM :: (MergeableM m, Mergeable a) => m a -mergeDefaultM = mergeAllM Nothing - -instance Mergeable () where - mergeAny = const () - mergeAll = const () +class (Bounded a, Mergeable a) => PreserveMerge a where + type T a :: * + convertMerge :: Mergeable b => (T a -> b) -> a -> b -instance Mergeable [a] where - mergeAny = foldr (++) [] - mergeAll = foldr (++) [] +instance Mergeable Bool where + mergeAny = foldr (||) False + mergeAll = foldr (&&) True instance (Ord k, Mergeable a) => Mergeable (Map k a) where mergeAny = Map.fromListWith (\x y -> mergeAny [x,y]) . foldr ((++) . Map.toList) [] mergeAll = Map.fromListWith (\x y -> mergeAll [x,y]) . foldr ((++) . Map.toList) [] - -instance MergeableM Maybe where - mergeAnyM = fmap mergeAny . foldr ((<>) . fmap (:[])) Nothing - mergeAllM = fmap mergeAll . sequence . foldr (:) [] - -instance MergeableM Identity where - mergeAnyM = Identity . mergeAny . foldr ((:) . runIdentity) [] - mergeAllM = Identity . mergeAll . foldr ((:) . runIdentity) [] diff --git a/src/Cli/CompileOptions.hs b/src/Cli/CompileOptions.hs --- a/src/Cli/CompileOptions.hs +++ b/src/Cli/CompileOptions.hs @@ -74,7 +74,7 @@ CategorySource { csSource :: FilePath, csCategories :: [CategoryName], - csDepCategories :: [CategoryName] + csRequires :: [CategoryName] } | OtherSource { osSource :: FilePath diff --git a/src/Cli/Compiler.hs b/src/Cli/Compiler.hs --- a/src/Cli/Compiler.hs +++ b/src/Cli/Compiler.hs @@ -27,6 +27,7 @@ import Control.Monad (foldM,when) import Data.Either (partitionEithers) import Data.List (isSuffixOf,nub,sort) +import Data.Time.LocalTime (getZonedTime) import System.Directory import System.FilePath import System.Posix.Temp (mkstemps) @@ -50,6 +51,7 @@ import Types.Builtin import Types.DefinedCategory import Types.Pragma +import Types.Procedure (isLiteralCategory) import Types.TypeCategory import Types.TypeInstance @@ -100,47 +102,55 @@ else do bpDeps <- loadPublicDeps compilerHash f ca2 [base] return $ bpDeps ++ deps1 - ns0 <- createPublicNamespace p d + time <- errorFromIO getZonedTime + path <- errorFromIO $ canonicalizePath $ p d + -- NOTE: Making the public namespace deterministic allows freshness checks to + -- skip checking all inputs/outputs for each dependency. + let ns0 = StaticNamespace $ publicNamespace $ show compilerHash ++ path + let ns1 = StaticNamespace . privateNamespace $ show time ++ show compilerHash ++ path let ex = concat $ map getSourceCategories es - cs <- loadModuleGlobals resolver p ns0 ps deps1' deps2 - let cm = createLanguageModule ex em cs + let ss = filter (not . isLiteralCategory) ex + cs <- loadModuleGlobals resolver p (ns0,ns1) ps Nothing deps1' deps2 + let cm = createLanguageModule ex ss em cs let cs2 = filter (not . hasCodeVisibility FromDependency) cs let pc = map (getCategoryName . wvData) $ filter (not . hasCodeVisibility ModuleOnly) cs2 let tc = map (getCategoryName . wvData) $ filter (hasCodeVisibility ModuleOnly) cs2 let dc = map (getCategoryName . wvData) $ filter (hasCodeVisibility FromDependency) $ filter (not . hasCodeVisibility ModuleOnly) cs - xa <- mapErrorsM (loadPrivateSource resolver p) xs - (xx1,xx2) <- compileLanguageModule cm xa + xa <- mapErrorsM (loadPrivateSource resolver compilerHash p) xs + fs <- compileLanguageModule cm xa mf <- maybeCreateMain cm xa m - let fs' = xx1++xx2 eraseCachedData (p d) let ps2 = map takeFileName ps let xs2 = map takeFileName xs let ts2 = map takeFileName ts - let paths = map (\ns -> getCachedPath (p d) ns "") $ nub $ filter (not . null) $ map show $ [ns0] ++ map coNamespace fs' + let paths = map (\ns -> getCachedPath (p d) ns "") $ nub $ filter (not . null) $ map show $ map coNamespace fs paths' <- mapM (errorFromIO . canonicalizePath) paths s0 <- errorFromIO $ canonicalizePath $ getCachedPath (p d) (show ns0) "" - let paths2 = base:(getIncludePathsForDeps (deps1' ++ deps2)) ++ ep' ++ paths' - let hxx = filter (isSuffixOf ".hpp" . coFilename) fs' - let other = filter (not . isSuffixOf ".hpp" . coFilename) fs' - os1 <- mapErrorsM (writeOutputFile (show ns0) paths2) $ hxx ++ other - let files = map (\f2 -> getCachedPath (p d) (show $ coNamespace f2) (coFilename f2)) fs' ++ + s1 <- errorFromIO $ canonicalizePath $ getCachedPath (p d) (show ns1) "" + let paths2 = base:s0:s1:(getIncludePathsForDeps (deps1' ++ deps2)) ++ ep' ++ paths' + let hxx = filter (isSuffixOf ".hpp" . coFilename) fs + let other = filter (not . isSuffixOf ".hpp" . coFilename) fs + os1 <- mapErrorsM (writeOutputFile paths2) $ hxx ++ other + let files = map (\f2 -> getCachedPath (p d) (show $ coNamespace f2) (coFilename f2)) fs ++ map (\f2 -> p getSourceFile f2) es files' <- mapErrorsM checkOwnedFile files - os2 <- fmap concat $ mapErrorsM (compileExtraSource (show ns0) paths2) es + let ca = Map.fromList $ map (\c -> (getCategoryName c,getCategoryNamespace c)) $ map wvData cs2 + os2 <- fmap concat $ mapErrorsM (compileExtraSource (ns0,ns1) ca paths2) es let (hxx',cxx,os') = sortCompiledFiles files' let (osCat,osOther) = partitionEithers os2 - path <- errorFromIO $ canonicalizePath $ p d let os1' = resolveObjectDeps (deps1' ++ deps2) path path (os1 ++ osCat) warnPublic resolver (p d) pc dc os1' is let cm2 = CompileMetadata { cmVersionHash = compilerHash, cmPath = path, - cmNamespace = ns0, + cmPublicNamespace = ns0, + cmPrivateNamespace = ns1, cmPublicDeps = as, cmPrivateDeps = as2, cmPublicCategories = sort pc, cmPrivateCategories = sort tc, - cmSubdirs = [s0], + cmPublicSubdirs = [s0], + cmPrivateSubdirs = [s1], cmPublicFiles = sort ps2, cmPrivateFiles = sort xs2, cmTestFiles = sort ts2, @@ -154,12 +164,14 @@ let cm2' = CompileMetadata { cmVersionHash = cmVersionHash cm2, cmPath = cmPath cm2, - cmNamespace = cmNamespace cm2, + cmPublicNamespace = cmPublicNamespace cm2, + cmPrivateNamespace = cmPrivateNamespace cm2, cmPublicDeps = cmPublicDeps cm2, cmPrivateDeps = cmPrivateDeps cm2, cmPublicCategories = cmPublicCategories cm2, cmPrivateCategories = cmPrivateCategories cm2, - cmSubdirs = cmSubdirs cm2, + cmPublicSubdirs = cmPublicSubdirs cm2, + cmPrivateSubdirs = cmPrivateSubdirs cm2, cmPublicFiles = cmPublicFiles cm2, cmPrivateFiles = cmPrivateFiles cm2, cmTestFiles = cmTestFiles cm2, @@ -172,7 +184,7 @@ writeMetadata (p d) cm2' where compilerHash = getCompilerHash backend ep' = fixPaths $ map (p ) ep - writeOutputFile ns0 paths ca@(CxxOutput _ f2 ns _ _ content) = do + writeOutputFile paths ca@(CxxOutput _ f2 ns _ _ content) = do errorFromIO $ hPutStrLn stderr $ "Writing file " ++ f2 writeCachedFile (p d) (show ns) f2 $ concat $ map (++ "\n") content if isSuffixOf ".cpp" f2 || isSuffixOf ".cc" f2 @@ -181,40 +193,42 @@ 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 f2' (getCachedPath (p d) ns' "") dynamicNamespaceName "" (p0:p1:paths) False + let ms = [] + let command = CompileToObject f2' (getCachedPath (p d) (show ns) "") ms (p0:p1:paths) False o2 <- runCxxCommand backend command return $ ([o2],ca) else return ([],ca) - compileExtraSource ns0 paths (CategorySource f2 cs ds2) = do - f2' <- compileExtraFile False ns0 paths f2 - let ds2' = nub $ cs ++ ds2 + compileExtraSource (ns0,ns1) ca paths (CategorySource f2 cs ds2) = do + f2' <- compileExtraFile False (ns0,ns1) paths f2 case f2' of Nothing -> return [] - Just o -> return $ map (\c -> Left $ ([o],fakeCxxForSource ns0 ds2' c)) cs - compileExtraSource ns0 paths (OtherSource f2) = do - f2' <- compileExtraFile True ns0 paths f2 + Just o -> return $ map (\c -> Left $ ([o],fakeCxx c)) cs + where + fakeCxx c = CxxOutput { + coCategory = Just c, + coFilename = "", + coNamespace = case c `Map.lookup` ca of + Just ns2 -> ns2 + Nothing -> NoNamespace, + coUsesNamespace = [ns0,ns1], + coUsesCategory = ds2, + coOutput = [] + } + compileExtraSource _ _ paths (OtherSource f2) = do + f2' <- compileExtraFile True (NoNamespace,NoNamespace) paths f2 case f2' of Just o -> return [Right $ OtherObjectFile o] Nothing -> return [] - fakeCxxForSource ns ds2 c = CxxOutput { - coCategory = Just c, - coFilename = "", - coNamespace = ns', - coUsesNamespace = [ns'], - coUsesCategory = ds2, - coOutput = [] - } where - ns' = if null ns then NoNamespace else StaticNamespace ns checkOwnedFile f2 = do exists <- errorFromIO $ doesFileExist f2 when (not exists) $ compileErrorM $ "Owned file " ++ f2 ++ " does not exist." errorFromIO $ canonicalizePath f2 - compileExtraFile e ns0 paths f2 + compileExtraFile e (ns0,ns1) paths f2 | isSuffixOf ".cpp" f2 || isSuffixOf ".cc" f2 = do let f2' = p f2 createCachePath (p d) - let command = CompileToObject f2' (getCachedPath (p d) "" "") dynamicNamespaceName ns0 paths e + let ms = [(publicNamespaceMacro,Just $ show ns0),(privateNamespaceMacro,Just $ show ns1)] + let command = CompileToObject f2' (getCachedPath (p d) "" "") ms paths e fmap Just $ runCxxCommand backend command | isSuffixOf ".a" f2 || isSuffixOf ".o" f2 = return (Just f2) | otherwise = return Nothing @@ -250,10 +264,9 @@ createModuleTemplates :: PathIOHandler r => r -> FilePath -> FilePath -> [CompileMetadata] -> [CompileMetadata] -> CompileInfoIO () createModuleTemplates resolver p d deps1 deps2 = do - ns0 <- createPublicNamespace p d (ps,xs,_) <- findSourceFiles p d - (LanguageModule _ _ _ cs0 ps0 ts0 cs1 ps1 ts1 _ _) <- - fmap (createLanguageModule [] Map.empty) $ loadModuleGlobals resolver p ns0 ps deps1 deps2 + (LanguageModule _ _ _ cs0 ps0 ts0 cs1 ps1 ts1 _ _ _) <- + fmap (createLanguageModule [] [] Map.empty) $ loadModuleGlobals resolver p (PublicNamespace,PrivateNamespace) ps Nothing deps1 deps2 xs' <- zipWithContents resolver p xs ds <- mapErrorsM parseInternalSource xs' let ds2 = concat $ map (\(_,_,d2) -> d2) ds @@ -261,7 +274,8 @@ let cs = filter isValueConcrete $ cs1++ps1++ts1 let ca = Set.fromList $ map getCategoryName $ filter isValueConcrete cs let ca' = foldr Set.delete ca $ map dcName ds2 - ts <- mapErrorsM (compileConcreteTemplate tm) $ Set.toList ca' + let testingCats = Set.fromList $ map getCategoryName ts1 + ts <- mapErrorsM (\n -> compileConcreteTemplate (n `Set.member` testingCats) tm n) $ Set.toList ca' mapErrorsM_ writeTemplate ts where writeTemplate (CxxOutput _ n _ _ _ content) = do let n' = p d n @@ -275,34 +289,30 @@ runModuleTests :: (PathIOHandler r, CompilerBackend b) => r -> b -> FilePath -> [FilePath] -> LoadedTests -> CompileInfoIO [((Int,Int),CompileInfo ())] runModuleTests resolver backend base tp (LoadedTests p d m em deps1 deps2) = do - let paths = base:(getIncludePathsForDeps deps1) + let paths = base:(cmPublicSubdirs m ++ cmPrivateSubdirs m ++ getIncludePathsForDeps deps1) mapErrorsM_ showSkipped $ filter (not . isTestAllowed) $ cmTestFiles m ts' <- zipWithContents resolver p $ map (d ) $ filter isTestAllowed $ cmTestFiles m path <- errorFromIO $ canonicalizePath (p d) - cm <- fmap (createLanguageModule [] em) $ loadModuleGlobals resolver path NoNamespace [] deps1 [] + cm <- fmap (createLanguageModule [] [] em) $ loadModuleGlobals resolver path (NoNamespace,NoNamespace) [] (Just m) deps1 [] mapErrorsM (runSingleTest backend cm path paths (m:deps2)) ts' where allowTests = Set.fromList tp isTestAllowed t = if null allowTests then True else t `Set.member` allowTests showSkipped f = compileWarningM $ "Skipping tests in " ++ f ++ " due to explicit test filter." -createPublicNamespace :: FilePath -> FilePath -> CompileInfoIO Namespace -createPublicNamespace p d = (errorFromIO $ canonicalizePath (p d)) >>= return . StaticNamespace . publicNamespace - -createPrivateNamespace :: FilePath -> FilePath -> CompileInfoIO Namespace -createPrivateNamespace p f = (errorFromIO $ canonicalizePath (p f)) >>= return . StaticNamespace . privateNamespace - -loadPrivateSource :: PathIOHandler r => r -> FilePath -> FilePath -> CompileInfoIO (PrivateSource SourcePos) -loadPrivateSource resolver p f = do +loadPrivateSource :: PathIOHandler r => r -> VersionHash -> FilePath -> FilePath -> CompileInfoIO (PrivateSource SourcePos) +loadPrivateSource resolver h p f = do [f'] <- zipWithContents resolver p [f] - ns <- createPrivateNamespace p f + time <- errorFromIO getZonedTime + path <- errorFromIO $ canonicalizePath (p f) + let ns = StaticNamespace $ privateNamespace $ show time ++ show h ++ path (pragmas,cs,ds) <- parseInternalSource f' let cs' = map (setCategoryNamespace ns) cs let testing = any isTestsOnly pragmas return $ PrivateSource ns testing cs' ds -createLanguageModule :: [CategoryName] -> ExprMap c -> +createLanguageModule :: [CategoryName] -> [CategoryName] -> ExprMap c -> [WithVisibility (AnyCategory c)] -> LanguageModule c -createLanguageModule ex em cs = lm where +createLanguageModule ex ss em cs = lm where lm = LanguageModule { lmPublicNamespaces = map wvData $ apply ns [with FromDependency,without ModuleOnly,without TestsOnly], lmPrivateNamespaces = map wvData $ apply ns [with FromDependency,with ModuleOnly,without TestsOnly], @@ -314,6 +324,7 @@ lmPrivateLocal = map wvData $ apply cs [without FromDependency,with ModuleOnly,without TestsOnly], lmTestingLocal = map wvData $ apply cs [without FromDependency,with TestsOnly], lmExternal = ex, + lmStreamlined = ss, lmExprMap = em } ns = map (mapCodeVisibility getCategoryNamespace) cs diff --git a/src/Cli/Programs.hs b/src/Cli/Programs.hs --- a/src/Cli/Programs.hs +++ b/src/Cli/Programs.hs @@ -45,8 +45,7 @@ CompileToObject { ctoSource :: String, ctoPath :: String, - ctoNamespaceMacro :: String, - ctoNamespace :: String, + ctoMacros :: [(String,Maybe String)], ctoPaths :: [String], ctoExtra :: Bool } | diff --git a/src/Cli/RunCompiler.hs b/src/Cli/RunCompiler.hs --- a/src/Cli/RunCompiler.hs +++ b/src/Cli/RunCompiler.hs @@ -31,7 +31,6 @@ import Base.CompileError import Base.CompileInfo -import Base.Mergeable import Cli.CompileOptions import Cli.Compiler import Cli.Programs @@ -61,7 +60,7 @@ deps2 <- loadPrivateDeps compilerHash f ca4 (deps0++[m]++deps1) let ca5 = ca4 `Map.union` mapMetadata deps2 em <- getExprMap (p d) rm - return (ca5,ms ++ [LoadedTests p d m em (deps0++[m]++deps1) deps2]) + return (ca5,ms ++ [LoadedTests p d m em (deps0++deps1) deps2]) checkTestFilters ts = do let possibleTests = Set.fromList $ concat $ map (cmTestFiles . ltMetadata) ts case Set.toList $ (Set.fromList tp) `Set.difference` possibleTests of @@ -70,7 +69,7 @@ intercalate ", " (map show fs) ++ "\n" processResults passed failed rs | isCompileError rs = - (fromCompileInfo rs) f2) let rm = ModuleConfig { - rmRoot = "", - rmPath = ".", - rmExprMap = [], - rmPublicDeps = [], - rmPrivateDeps = [], - rmExtraFiles = [], - rmExtraPaths = [], - rmMode = CompileUnspecified + mcRoot = "", + mcPath = ".", + mcExprMap = [], + mcPublicDeps = [], + mcPrivateDeps = [], + mcExtraFiles = [], + mcExtraPaths = [], + mcMode = CompileUnspecified } em <- getExprMap p rm let spec = ModuleSpec { @@ -118,16 +117,16 @@ else do d <- errorFromIO $ canonicalizePath (p d0) rm <- loadRecompile d - if rmPath rm `Set.member` da + if mcPath rm `Set.member` da then return da else do - let ds3 = map (\d2 -> d d2) (rmPublicDeps rm ++ rmPrivateDeps rm) - da' <- foldM (recursive r) (rmPath rm `Set.insert` da) ds3 + let ds3 = map (\d2 -> d d2) (mcPublicDeps rm ++ mcPrivateDeps rm) + da' <- foldM (recursive r) (mcPath rm `Set.insert` da) ds3 runCompiler resolver backend (CompileOptions h [] [] [d] [] [] p CompileRecompile f) return da' runCompiler resolver backend (CompileOptions _ _ _ ds _ _ p CompileRecompile f) = do - mergeAllM $ map recompileSingle ds where + mapErrorsM_ recompileSingle ds where compilerHash = getCompilerHash backend recompileSingle d0 = do d <- errorFromIO $ canonicalizePath (p d0) @@ -174,20 +173,20 @@ compileSingle d = do as <- fmap fixPaths $ mapErrorsM (resolveModule resolver (p d)) is as2 <- fmap fixPaths $ mapErrorsM (resolveModule resolver (p d)) is2 - isConfigured <- isPathConfigured d + isConfigured <- isPathConfigured p d when (isConfigured && f == DoNotForce) $ do compileErrorM $ "Module " ++ d ++ " has an existing configuration. " ++ "Recompile with -r or use -f to overwrite the config." absolute <- errorFromIO $ canonicalizePath p let rm = ModuleConfig { - rmRoot = absolute, - rmPath = d, - rmExprMap = [], - rmPublicDeps = as, - rmPrivateDeps = as2, - rmExtraFiles = es, - rmExtraPaths = ep, - rmMode = m + mcRoot = absolute, + mcPath = d, + mcExprMap = [], + mcPublicDeps = as, + mcPrivateDeps = as2, + mcExtraFiles = es, + mcExtraPaths = ep, + mcMode = m } writeRecompile (p d) rm runCompiler resolver backend (CompileOptions h [] [] [d] [] [] p CompileRecompile DoNotForce) diff --git a/src/Cli/TestRunner.hs b/src/Cli/TestRunner.hs --- a/src/Cli/TestRunner.hs +++ b/src/Cli/TestRunner.hs @@ -32,7 +32,6 @@ import Base.CompileError import Base.CompileInfo -import Base.Mergeable import Cli.Programs import CompilerCxx.Category import CompilerCxx.Naming @@ -60,7 +59,7 @@ allResults <- sequence $ map runSingle ts' let passed = length $ filter (not . isCompileError) allResults let failed = length $ filter isCompileError allResults - return ((passed,failed),mergeAllM allResults) + return ((passed,failed),collectAllM_ allResults) runSingle t = do let name = "\"" ++ ithTestName (itHeader t) ++ "\" (from " ++ f ++ ")" let context = formatFullContextBrace (ithContext $ itHeader t) @@ -77,9 +76,9 @@ if not $ isCompileError result then undefined -- Should be caught in compileAll. else return $ do - let warnings = getCompileWarnings result - let errors = show $ getCompileError result - checkContent rs es (warnings ++ lines errors) [] [] + let warnings = show $ getCompileWarnings result + let errors = show $ getCompileError result + checkContent rs es (lines warnings ++ lines errors) [] [] run (ExpectRuntimeError _ e rs es) cs ds = execute False e rs es cs ds run (ExpectRuntimeSuccess _ e rs es) cs ds = execute True e rs es cs ds @@ -89,16 +88,16 @@ let ce = checkExcluded es comp err out let compError = if null comp then return () - else (mergeAllM $ map compileErrorM comp) mergeAllM $ map compileErrorM $ warnings ++ err ++ out + (True,False) -> collectAllM_ $ (asCompileError result):(map compileErrorM $ err ++ out) (False,True) -> - if null warnings + if isEmptyCompileMessage warnings then compileErrorM "Expected runtime failure" - else mergeAllM [compileErrorM "Expected runtime failure", - (mergeAllM $ map compileErrorM warnings) do - let result2 = checkContent rs es warnings err out + let result2 = checkContent rs es (lines $ show warnings) err out when (not $ isCompileError result2) $ errorFromIO $ removeDirectoryRecursive dir fromCompileInfo result2 @@ -131,14 +130,14 @@ psCategory = cs', psDefine = ds } - (_,xx) <- compileLanguageModule cm [xs] + xx <- compileLanguageModule cm [xs] main <- case e of Just e2 -> compileTestMain cm xs e2 Nothing -> compileErrorM "" return (xx,main) - 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 + checkRequired rs comp err out = mapErrorsM_ (checkSubsetForRegex True comp err out) rs + checkExcluded es comp err out = mapErrorsM_ (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) = diff --git a/src/Compilation/CompilerState.hs b/src/Compilation/CompilerState.hs --- a/src/Compilation/CompilerState.hs +++ b/src/Compilation/CompilerState.hs @@ -16,6 +16,7 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com] +{-# LANGUAGE CPP #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Safe #-} @@ -33,6 +34,9 @@ ReturnVariable(..), (), + (), + concatM, csAddVariable, csAllFilters, csCheckValueInit, @@ -71,14 +75,16 @@ import Control.Monad.Trans (lift) import Control.Monad.Trans.State (StateT(..),execStateT,get,mapStateT,put) -import Data.Foldable import Data.Functor -import Data.Monoid import Prelude hiding (foldr) import qualified Data.Set as Set +#if MIN_VERSION_base(4,11,0) +#else +import Data.Semigroup +#endif + import Base.CompileError -import Base.Mergeable import Types.DefinedCategory import Types.Positional import Types.Procedure @@ -168,13 +174,19 @@ instance Show c => Show (VariableValue c) where show (VariableValue c _ t _) = show t ++ formatFullContextBrace c -( CompilerState a m b -> String -> CompilerState a m b +( CompilerState a m b -> String -> CompilerState a m b () :: (CompileErrorM m) => String -> CompilerState a m b -> CompilerState a m b +(???>) :: CompileErrorM m => String -> CompilerState a m b -> CompilerState a m b (???>) s x = mapStateT (s ??>) x -resetBackgroundStateT :: (CompileErrorM m) => CompilerState a m b -> CompilerState a m b +( CompilerState a m b -> String -> CompilerState a m b +() :: CompileErrorM m => String -> CompilerState a m b -> CompilerState a m b +(!!!>) s x = mapStateT (s !!>) x + +resetBackgroundStateT :: CompileErrorM m => CompilerState a m b -> CompilerState a m b resetBackgroundStateT x = mapStateT resetBackgroundM x csCurrentScope :: CompilerContext c m s a => CompilerState a m SymbolScope @@ -283,16 +295,14 @@ 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 +instance Semigroup s => Semigroup (CompiledData s) where + (CompiledData r1 s1) <> (CompiledData r2 s2) = + CompiledData (r1 `Set.union` r2) (s1 <> s2) +instance (Semigroup s, Monoid s) => Monoid (CompiledData s) where + mempty = CompiledData Set.empty mempty + mappend = (<>) + runDataCompiler :: CompilerContext c m s a => CompilerState a m b -> a -> m (CompiledData s) runDataCompiler x ctx = do @@ -303,6 +313,9 @@ cdRequired = required, cdOutput = output } + +concatM :: (Semigroup s, Monoid s, CompileErrorM m) => [m (CompiledData s)] -> m (CompiledData s) +concatM = fmap mconcat . collectAllM getCleanContext :: CompilerContext c m s a => CompilerState a m a getCleanContext = get >>= lift . ccClearOutput diff --git a/src/Compilation/ProcedureContext.hs b/src/Compilation/ProcedureContext.hs --- a/src/Compilation/ProcedureContext.hs +++ b/src/Compilation/ProcedureContext.hs @@ -33,7 +33,7 @@ import qualified Data.Set as Set import Base.CompileError -import Base.Mergeable +import Base.MergeTree import Compilation.CompilerState import Types.DefinedCategory import Types.GeneralType @@ -83,12 +83,12 @@ vnRemaining :: Map.Map VariableName (PassedValue c) } -instance (Show c, MergeableM m, CompileErrorM m) => +instance (Show c, 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 False . vpParam) $ pcExtParams ctx) + same = TypeInstance (pcType ctx) (fmap (singleType . JustParamName False . vpParam) $ pcExtParams ctx) ccAllFilters = return . pcAllFilters ccGetParamScope ctx p = do case p `Map.lookup` pcParamScopes ctx of @@ -144,22 +144,25 @@ " does not have a category function named " ++ show n ++ formatFullContextBrace c ccGetTypeFunction ctx c t n = getFunction t where - getFunction (Just t2@(TypeMerge MergeUnion _)) = - compileErrorM $ "Use explicit type conversion to call " ++ show n ++ " for union type " ++ - show t2 ++ formatFullContextBrace c - getFunction (Just ta@(TypeMerge MergeIntersect ts)) = - collectOneOrErrorM (map getFunction $ map Just ts) return fs _ -> compileErrorM $ "Param " ++ show p ++ " does not exist" let ts = map tfType $ filter isRequiresFilter fs let ds = map dfType $ filter isDefinesFilter fs - collectOneOrErrorM (map (getFunction . Just . SingleType) ts ++ map checkDefine ds) (sfName f,f)) $ getCategoryFunctions ca subAndCheckFunction (tiName t2) params (tiParams t2) $ n `Map.lookup` fa - getFunction Nothing = do - let ps = fmap (SingleType . JustParamName False . vpParam) $ pcExtParams ctx - getFunction (Just $ SingleType $ JustTypeInstance $ TypeInstance (pcType ctx) ps) - getFunction (Just t2) = compileErrorM $ "Type " ++ show t2 ++ " contains unresolved types" + getFromSingle _ = compileErrorM $ "Type " ++ show t ++ " contains unresolved types" checkDefine t2 = do (_,ca) <- getCategory (pcCategories ctx) (c,diName t2) let params = Positional $ map vpParam $ getCategoryParams ca @@ -223,7 +223,7 @@ assignFilters fm fs = do mapErrorsM (uncheckedSubFilter $ getValueForParam fm) fs checkInit r fa (MemberValue c2 n t0) (i,t1) = do - checkValueTypeMatch r fa t1 t0 check (ValidatePositions ts) >> return () - Nothing -> mergeAllM $ map alwaysError $ Map.toList ra + Just _ -> check (ValidatePositions ts) >> return () + Nothing -> mapErrorsM_ alwaysError $ Map.toList ra return (ValidateNames ns ts Map.empty) alwaysError (n,t) = compileErrorM $ "Named return " ++ show n ++ " (" ++ show t ++ ") might not have been set before return at " ++ @@ -606,7 +606,7 @@ } ccGetNoTrace = return . pcNoTrace -updateReturnVariables :: (Show c, CompileErrorM m, MergeableM m) => +updateReturnVariables :: (Show c, CompileErrorM m) => (Map.Map VariableName (VariableValue c)) -> Positional (PassedValue c) -> ReturnValues c -> m (Map.Map VariableName (VariableValue c)) @@ -625,7 +625,7 @@ " is already defined" ++ formatFullContextBrace (vvContext v) -updateArgVariables :: (Show c, CompileErrorM m, MergeableM m) => +updateArgVariables :: (Show c, CompileErrorM m) => (Map.Map VariableName (VariableValue c)) -> Positional (PassedValue c) -> ArgValues c -> m (Map.Map VariableName (VariableValue c)) diff --git a/src/Compilation/ScopeContext.hs b/src/Compilation/ScopeContext.hs --- a/src/Compilation/ScopeContext.hs +++ b/src/Compilation/ScopeContext.hs @@ -31,7 +31,6 @@ import qualified Data.Map as Map import Base.CompileError -import Base.Mergeable import Compilation.ProcedureContext import Types.DefinedCategory import Types.GeneralType @@ -65,18 +64,19 @@ (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) => +getProcedureScopes :: (Show c, CompileErrorM m) => CategoryMap c -> ExprMap c -> DefinedCategory c -> m [ProcedureScope c] getProcedureScopes ta em (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 False . vpParam) params + let typeInstance = TypeInstance n $ fmap (singleType . JustParamName False . 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) + fm <- getCategoryFilterMap t + checkInternalParams pi fi (getCategoryParams t) (Map.elems fa) r fm pa <- pairProceduresToFunctions fa ps let (cp,tp,vp) = partitionByScope (sfScope . fst) pa let (cm,tm,vm) = partitionByScope dmScope ms @@ -97,25 +97,25 @@ builtins t s0 = Map.filter ((<= s0) . vvScope) $ builtinVariables t checkInternalParams pi2 fi2 pe fs2 r fa = do let pm = Map.fromList $ map (\p -> (vpParam p,vpContext p)) pi2 - mergeAllM $ map (checkFunction pm) fs2 - mergeAllM $ map (checkParam pm) pe - let fa' = Map.union fa $ getFilterMap pi2 fi2 - mergeAllM $ map (checkFilter r fa') fi2 + mapErrorsM_ (checkFunction pm) fs2 + mapErrorsM_ (checkParam pm) pe + fa' <- fmap (Map.union fa) $ getFilterMap pi2 fi2 + mapErrorsM_ (checkFilter r fa') fi2 checkFilter r fa (ParamFilter c2 n2 f) = - validateTypeFilter r fa f return () (Just c2) -> compileErrorM $ "Internal param " ++ show (vpParam p) ++ - formatFullContextBrace (vpContext p) ++ - " is already defined at " ++ - formatFullContext c2 + formatFullContextBrace (vpContext p) ++ + " is already defined at " ++ + formatFullContext c2 -- 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) + (VariableName "self",VariableValue [] ValueScope (ValueType RequiredValue $ singleType $ JustTypeInstance t) False) ] diff --git a/src/CompilerCxx/Category.hs b/src/CompilerCxx/Category.hs --- a/src/CompilerCxx/Category.hs +++ b/src/CompilerCxx/Category.hs @@ -32,14 +32,14 @@ compileTestMain, ) where -import Control.Monad (foldM) +import Control.Monad (foldM,when) import Data.List (intercalate,sortBy) import Prelude hiding (pi) import qualified Data.Map as Map import qualified Data.Set as Set import Base.CompileError -import Base.Mergeable +import Base.MergeTree import Compilation.CompilerState import Compilation.ProcedureContext (ExprMap) import Compilation.ScopeContext @@ -81,6 +81,7 @@ lmPrivateLocal :: [AnyCategory c], lmTestingLocal :: [AnyCategory c], lmExternal :: [CategoryName], + lmStreamlined :: [CategoryName], lmExprMap :: ExprMap c } @@ -92,37 +93,38 @@ psDefine :: [DefinedCategory c] } -compileLanguageModule :: (Show c, CompileErrorM m, MergeableM m) => - LanguageModule c -> [PrivateSource c] -> m ([CxxOutput],[CxxOutput]) -compileLanguageModule (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 ex em) xa = do +compileLanguageModule :: (Show c, CompileErrorM m) => + LanguageModule c -> [PrivateSource c] -> m [CxxOutput] +compileLanguageModule (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 ex ss em) xa = do checkSupefluous $ Set.toList $ (Set.fromList ex) `Set.difference` ca -- Check public sources up front so that error messages aren't duplicated for -- every source file. - _ <- tmTesting - (hxx1,cxx1) <- fmap mergeGeneratedP $ mapErrorsM (compileSourceP tmPublic nsPublic) cs1 - (hxx2,cxx2) <- fmap mergeGeneratedP $ mapErrorsM (compileSourceP tmPrivate nsPrivate) ps1 - (hxx3,cxx3) <- fmap mergeGeneratedP $ mapErrorsM (compileSourceP tmTesting nsTesting) ts1 - (ds,xx) <- fmap mergeGeneratedX $ mapErrorsM compileSourceX xa + ta <- tmTesting + xx1 <- fmap concat $ mapErrorsM (compileSourceP False tmPublic nsPublic) cs1 + xx2 <- fmap concat $ mapErrorsM (compileSourceP False tmPrivate nsPrivate) ps1 + xx3 <- fmap concat $ mapErrorsM (compileSourceP True tmTesting nsTesting) ts1 + (ds,xx4) <- fmap mergeGeneratedX $ mapErrorsM compileSourceX xa + xx5 <- fmap concat $ mapErrorsM (\s -> compileConcreteStreamlined (s `Set.member` testingCats) ta s) ss -- TODO: This should account for a name clash between a category declared in a -- TestsOnly .0rp and one declared in a non-TestOnly .0rx. let dm = mapByName ds checkDefined dm ex $ filter isValueConcrete (cs1 ++ ps1 ++ ts1) - return (hxx1 ++ hxx2 ++ hxx3 ++ cxx1 ++ cxx2 ++ cxx3,xx) where + checkStreamlined + return $ xx1 ++ xx2 ++ xx3 ++ xx4 ++ xx5 where + testingCats = Set.fromList $ map getCategoryName ts1 tmPublic = foldM includeNewTypes defaultCategories [cs0,cs1] tmPrivate = tmPublic >>= \tm -> foldM includeNewTypes tm [ps0,ps1] tmTesting = tmPrivate >>= \tm -> foldM includeNewTypes tm [ts0,ts1] nsPublic = ns0 ++ ns2 nsPrivate = nsPublic ++ ns1 nsTesting = nsPrivate - compileSourceP tm ns c = do + compileSourceP testing tm ns c = do tm' <- tm - hxx <- compileCategoryDeclaration tm' ns c + hxx <- compileCategoryDeclaration testing tm' ns c cxx <- if isValueConcrete c then return [] - else compileInterfaceDefinition c >>= return . (:[]) - return (hxx,cxx) - mergeGeneratedP ((hxx,cxx):ps) = let (hxx2,cxx2) = mergeGeneratedP ps in (hxx:hxx2,cxx++cxx2) - mergeGeneratedP _ = ([],[]) + else compileInterfaceDefinition testing c >>= return . (:[]) + return (hxx:cxx) compileSourceX (PrivateSource ns testing cs2 ds) = do tm <- if testing then tmTesting @@ -134,34 +136,44 @@ then cs1 ++ ps1 ++ ts1 else cs1 ++ ps1 checkLocals ds (ex ++ map getCategoryName (cs2 ++ cs)) + when testing $ checkTests ds (cs1 ++ ps1) let dm = mapByName ds checkDefined dm [] $ filter isValueConcrete cs2 tm' <- includeNewTypes tm cs2 -- Ensures that there isn't an inavertent collision when resolving -- dependencies for the module later on. tmTesting' <- tmTesting - _ <- (includeNewTypes tmTesting' cs2) >= return . getCategoryRefines - compileConcreteDefinition tm' em ns4 refines d + compileConcreteDefinition testing tm' em ns4 refines d mapByName = Map.fromListWith (++) . map (\d -> (dcName d,[d])) ca = Set.fromList $ map getCategoryName $ filter isValueConcrete (cs1 ++ ps1 ++ ts1) - checkLocals ds cs2 = mergeAllM $ map (checkLocal $ Set.fromList cs2) ds + checkLocals ds cs2 = mapErrorsM_ (checkLocal $ Set.fromList cs2) ds checkLocal cs2 d = - if dcName d `Set.member` cs2 - then return () - else compileErrorM ("Definition for " ++ show (dcName d) ++ + when (not $ dcName d `Set.member` cs2) $ + compileErrorM ("Definition for " ++ show (dcName d) ++ + formatFullContextBrace (dcContext d) ++ + " does not correspond to a visible category in this module") + checkTests ds ps = do + let pa = Map.fromList $ map (\c -> (getCategoryName c,getCategoryContext c)) $ filter isValueConcrete ps + mapErrorsM_ (checkTest pa) ds + checkTest pa d = + case dcName d `Map.lookup` pa of + Nothing -> return () + Just c -> + compileErrorM ("Category " ++ show (dcName d) ++ formatFullContextBrace (dcContext d) ++ - " does not correspond to a visible category in this module") - checkDefined dm ex2 = mergeAllM . map (checkSingle dm (Set.fromList ex2)) + " was not declared as $TestsOnly$" ++ formatFullContextBrace c) + checkDefined dm ex2 = mapErrorsM_ (checkSingle dm (Set.fromList ex2)) checkSingle dm es t = case (getCategoryName t `Set.member` es, getCategoryName t `Map.lookup` dm) of (False,Just [_]) -> return () @@ -177,24 +189,27 @@ (_,Just ds) -> ("Category " ++ show (getCategoryName t) ++ formatFullContextBrace (getCategoryContext t) ++ - " is defined " ++ show (length ds) ++ " times") ??> - (mergeAllM $ map (\d -> compileErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds) + " is defined " ++ show (length ds) ++ " times") !!> + (mapErrorsM_ (\d -> compileErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds) checkSupefluous es2 | null es2 = return () | otherwise = compileErrorM $ "External categories either not concrete or not present: " ++ - intercalate ", " (map show es2) + intercalate ", " (map show es2) + checkStreamlined = mapErrorsM_ streamlinedError $ Set.toList $ Set.difference (Set.fromList ss) (Set.fromList ex) + streamlinedError n = + compileErrorM $ "Category " ++ show n ++ " cannot be streamlined because it was not declared external" -compileTestMain :: (Show c, CompileErrorM m, MergeableM m) => +compileTestMain :: (Show c, CompileErrorM m) => LanguageModule c -> PrivateSource c -> Expression c -> m CxxOutput -compileTestMain (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 _ em) ts2 e = do +compileTestMain (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 _ _ em) ts2 e = do tm' <- tm (req,main) <- createTestFile tm' em e return $ CxxOutput Nothing testFilename NoNamespace ([psNamespace ts2]++ns0++ns1++ns2) req main where tm = foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1,ts0,ts1,psCategory ts2] -compileModuleMain :: (Show c, CompileErrorM m, MergeableM m) => +compileModuleMain :: (Show c, CompileErrorM m) => LanguageModule c -> [PrivateSource c] -> CategoryName -> FunctionName -> m CxxOutput -compileModuleMain (LanguageModule ns0 ns1 ns2 cs0 ps0 _ cs1 ps1 _ _ em) xa n f = do +compileModuleMain (LanguageModule ns0 ns1 ns2 cs0 ps0 _ cs1 ps1 _ _ _ em) xa n f = do let resolved = filter (\d -> dcName d == n) $ concat $ map psDefine $ filter (not . psTesting) xa reconcile resolved tm' <- tm @@ -206,21 +221,22 @@ reconcile [_] = return () reconcile [] = compileErrorM $ "No matches for main category " ++ show n ++ " ($TestsOnly$ sources excluded)" reconcile ds = - ("Multiple matches for main category " ++ show n) ??> - (mergeAllM $ map (\d -> compileErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds) + ("Multiple matches for main category " ++ show n) !!> + mapErrorsM_ (\d -> compileErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds -compileCategoryDeclaration :: (Show c, CompileErrorM m, MergeableM m) => - CategoryMap c -> [Namespace] -> AnyCategory c -> m CxxOutput -compileCategoryDeclaration _ ns t = +compileCategoryDeclaration :: (Show c, CompileErrorM m) => + Bool -> CategoryMap c -> [Namespace] -> AnyCategory c -> m CxxOutput +compileCategoryDeclaration testing _ ns t = return $ CxxOutput (Just $ getCategoryName t) (headerFilename name) (getCategoryNamespace t) (ns ++ [getCategoryNamespace t]) (Set.toList $ cdRequired file) (cdOutput file) where - file = mergeAll $ [ + file = mconcat $ [ CompiledData depends [], onlyCodes guardTop, + onlyCodes $ (if testing then testsOnlyCategoryGuard (getCategoryName t) else []), onlyCodes baseHeaderIncludes, addNamespace t content, onlyCodes guardBottom @@ -246,10 +262,10 @@ | isInstanceInterface t = [] | otherwise = declareGetType t -compileInterfaceDefinition :: MergeableM m => AnyCategory c -> m CxxOutput -compileInterfaceDefinition t = do +compileInterfaceDefinition :: CompileErrorM m => Bool -> AnyCategory c -> m CxxOutput +compileInterfaceDefinition testing t = do te <- typeConstructor - commonDefineAll t [] Nothing emptyCode emptyCode emptyCode te [] + commonDefineAll testing t [] Nothing emptyCode emptyCode emptyCode te [] where typeConstructor = do let ps = map vpParam $ getCategoryParams t @@ -257,15 +273,15 @@ 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..] :: [Int]) ps + let initPassed = map (\(i,p) -> paramName p ++ "(std::get<" ++ show i ++ ">(params))") $ zip ([0..] :: [Int]) 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 +compileConcreteTemplate :: (Show c, CompileErrorM m) => + Bool -> CategoryMap c -> CategoryName -> m CxxOutput +compileConcreteTemplate testing ta n = do (_,t) <- getConcreteCategory ta ([],n) - compileConcreteDefinition ta Map.empty [] Nothing (defined t) - CategoryMap c -> ExprMap c -> [Namespace] -> Maybe [ValueRefine c] -> +compileConcreteStreamlined :: (Show c, CompileErrorM m) => + Bool -> CategoryMap c -> CategoryName -> m [CxxOutput] +compileConcreteStreamlined testing ta n = ("In streamlined compilation of " ++ show n) ??> do + (_,t) <- getConcreteCategory ta ([],n) + let guard = if testing + then testsOnlySourceGuard + else noTestsOnlySourceGuard + -- TODO: Implement this. + let hxx = CxxOutput (Just $ getCategoryName t) + (headerStreamlined $ getCategoryName t) + (getCategoryNamespace t) + [getCategoryNamespace t] + (getCategoryMentions t) + guard + let cxx = CxxOutput (Just $ getCategoryName t) + (sourceStreamlined $ getCategoryName t) + (getCategoryNamespace t) + [getCategoryNamespace t] + (getCategoryMentions t) + [] + return [hxx,cxx] + +compileConcreteDefinition :: (Show c, CompileErrorM m) => + Bool -> CategoryMap c -> ExprMap c -> [Namespace] -> Maybe [ValueRefine c] -> DefinedCategory c -> m CxxOutput -compileConcreteDefinition ta em ns rs dd@(DefinedCategory c n pi _ _ fi ms _ fs) = do +compileConcreteDefinition testing ta em ns rs dd@(DefinedCategory c n pi _ _ fi ms _ fs) = do (_,t) <- getConcreteCategory ta (c,n) let r = CategoryResolver ta [cp,tp,vp] <- getProcedureScopes ta em dd let (cm,tm,vm) = partitionByScope dmScope ms let filters = getCategoryFilters t let filters2 = fi - let allFilters = getFilterMap (getCategoryParams t ++ pi) $ filters ++ filters2 + allFilters <- getFilterMap (getCategoryParams t ++ pi) $ filters ++ filters2 -- Functions explicitly declared externally. let externalFuncs = Set.fromList $ map sfName $ filter ((== n) . sfType) $ getCategoryFunctions t -- Functions explicitly declared internally. @@ -312,54 +350,54 @@ let internalFuncs = Map.filter (not . (`Set.member` externalFuncs) . sfName) overrideFuncs let fe = Map.elems internalFuncs let allFuncs = getCategoryFunctions t ++ fe - cf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure cp - ce <- mergeAllM [ + cf <- collectAllM $ applyProcedureScope compileExecutableProcedure cp + ce <- concatM [ categoryConstructor t cm, categoryDispatch allFuncs, - return $ mergeAll $ map fst cf, - mergeAllM $ map (createMemberLazy r allFilters) cm + return $ mconcat $ map fst cf, + concatM $ map (createMemberLazy r allFilters) cm ] - tf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure tp + tf <- collectAllM $ applyProcedureScope compileExecutableProcedure tp disallowTypeMembers tm - te <- mergeAllM [ + te <- concatM [ typeConstructor t tm, typeDispatch allFuncs, - return $ mergeAll $ map fst tf, - mergeAllM $ map (createMember r allFilters) tm + return $ mconcat $ map fst tf, + concatM $ map (createMember r allFilters) tm ] - vf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure vp + vf <- collectAllM $ applyProcedureScope compileExecutableProcedure vp let internalCount = length pi let memberCount = length vm - top <- mergeAllM [ + top <- concatM [ return $ onlyCode $ "class " ++ valueName n ++ ";", declareInternalValue n internalCount memberCount ] - defineValue <- mergeAllM [ + defineValue <- concatM [ return $ onlyCode $ "struct " ++ valueName n ++ " : public " ++ valueBase ++ " {", fmap indentCompiled $ valueConstructor vm, fmap indentCompiled $ valueDispatch allFuncs, - return $ indentCompiled $ defineCategoryName2 n, - return $ indentCompiled $ mergeAll $ map fst vf, - fmap indentCompiled $ mergeAllM $ map (createMember r allFilters) vm, + return $ indentCompiled $ defineCategoryName ValueScope n, + return $ indentCompiled $ mconcat $ map fst vf, + fmap indentCompiled $ concatM $ map (createMember r allFilters) vm, fmap indentCompiled $ createParams, - return $ indentCompiled $ onlyCode $ typeName n ++ "& parent;", + return $ indentCompiled $ onlyCode $ "const S<" ++ typeName n ++ "> parent;", return $ indentCompiled $ onlyCodes $ traceCreation (psProcedures vp), return $ onlyCode "};" ] - bottom <- mergeAllM $ [ + bottom <- concatM $ [ return $ defineValue, defineInternalValue n internalCount memberCount ] ++ map (return . snd) (cf ++ tf ++ vf) - commonDefineAll t ns rs top bottom ce te fe + commonDefineAll testing t ns rs top bottom ce te fe where - disallowTypeMembers :: (Show c, CompileErrorM m, MergeableM m) => + disallowTypeMembers :: (Show c, CompileErrorM m) => [DefinedMember c] -> m () disallowTypeMembers tm = - mergeAllM $ flip map tm + collectAllM_ $ flip map tm (\m -> compileErrorM $ "Member " ++ show (dmName m) ++ - " is not allowed to be @type-scoped" ++ - formatFullContextBrace (dmContext m)) - createParams = mergeAllM $ map createParam pi + " is not allowed to be @type-scoped" ++ + formatFullContextBrace (dmContext m)) + createParams = concatM $ 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. @@ -372,7 +410,7 @@ initMembers <- runDataCompiler (sequence $ map compileLazyInit ms2) ctx let initMembersStr = intercalate ", " $ cdOutput initMembers let initColon = if null initMembersStr then "" else " : " - mergeAllM [ + concatM [ return $ onlyCode $ categoryName n ++ "()" ++ initColon ++ initMembersStr ++ " {", return $ indentCompiled $ onlyCodes $ getCycleCheck (categoryName n), return $ indentCompiled $ onlyCode $ startFunctionTracing $ show n ++ " (init @category)", @@ -385,11 +423,11 @@ let paramsPassed = "Params<" ++ show (length ps2) ++ ">::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..] :: [Int]) ps2 + let initPassed = map (\(i,p) -> paramName p ++ "(std::get<" ++ show i ++ ">(params))") $ zip ([0..] :: [Int]) ps2 let allInit = intercalate ", " $ initParent:initPassed ctx <- getContextForInit ta em t dd TypeScope initMembers <- runDataCompiler (sequence $ map compileRegularInit ms2) ctx - mergeAllM [ + concatM [ return $ onlyCode $ typeName n ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {", return $ indentCompiled $ onlyCodes $ getCycleCheck (typeName n), return $ indentCompiled $ onlyCode $ startFunctionTracing $ show n ++ " (init @type)", @@ -397,12 +435,12 @@ return $ onlyCode "}" ] valueConstructor ms2 = do - let argParent = typeName n ++ "& p" + let argParent = "S<" ++ 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..] :: [Int]) pi + let initParams = map (\(i,p) -> paramName (vpParam p) ++ "(params.At(" ++ show i ++ "))") $ zip ([0..] :: [Int]) pi let initArgs = map (\(i,m) -> variableName (dmName m) ++ "(" ++ unwrappedArg i m ++ ")") $ zip ([0..] :: [Int]) ms2 let allInit = intercalate ", " $ initParent:(initParams ++ initArgs) return $ onlyCode $ valueName n ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" @@ -425,6 +463,7 @@ typeDispatch fs2 = return $ onlyCodes $ [ "ReturnTuple Dispatch(" ++ + "const S& self, " ++ "const TypeFunction& label, " ++ "const ParamTuple& params, " ++ "const ValueTuple& args) final {" @@ -441,19 +480,22 @@ | any isTraceCreation $ concat $ map (epPragmas . snd) vp = [captureCreationTrace] | otherwise = [] -commonDefineAll :: MergeableM m => - AnyCategory c -> [Namespace] -> Maybe [ValueRefine c] -> CompiledData [String] -> +commonDefineAll :: CompileErrorM m => + Bool -> AnyCategory c -> [Namespace] -> Maybe [ValueRefine c] -> CompiledData [String] -> CompiledData [String] -> CompiledData [String] -> - [ScopedFunction c] -> m CxxOutput -commonDefineAll t ns rs top bottom ce te fe = do + CompiledData [String] -> [ScopedFunction c] -> m CxxOutput +commonDefineAll testing t ns rs top bottom ce te fe = do let filename = sourceFilename name - (CompiledData req out) <- fmap (addNamespace t) $ mergeAllM $ [ + (CompiledData req out) <- fmap (addNamespace t) $ concatM $ [ return $ CompiledData (Set.fromList (name:getCategoryMentions t)) [], - return $ mergeAll [createCollection,createAllLabels] + return $ mconcat [createCollection,createAllLabels] ] ++ conditionalContent let rs' = case rs of Nothing -> [] Just rs2 -> rs2 + let guard = if testing + then testsOnlySourceGuard + else noTestsOnlySourceGuard let inherited = Set.unions $ (map (categoriesFromRefine . vrType) (getCategoryRefines t ++ rs')) ++ (map (categoriesFromDefine . vdType) $ getCategoryDefines t) let includes = map (\i -> "#include \"" ++ headerFilename i ++ "\"") $ @@ -463,7 +505,7 @@ (getCategoryNamespace t) ((getCategoryNamespace t):ns) (Set.toList req) - (baseSourceIncludes ++ includes ++ out) + (guard ++ baseSourceIncludes ++ includes ++ out) where conditionalContent | isInstanceInterface t = [] @@ -501,22 +543,32 @@ addNamespace :: AnyCategory c -> CompiledData [String] -> CompiledData [String] addNamespace t cs - | isStaticNamespace $ getCategoryNamespace t = mergeAll [ + | isStaticNamespace $ getCategoryNamespace t = mconcat [ 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, + | isPublicNamespace $ getCategoryNamespace t = mconcat [ + onlyCode $ "#ifdef " ++ publicNamespaceMacro, + onlyCode $ "namespace " ++ publicNamespaceMacro ++ " {", + onlyCode $ "#endif // " ++ publicNamespaceMacro, cs, - onlyCode $ "#ifdef " ++ dynamicNamespaceName, - onlyCode $ "} // namespace " ++ dynamicNamespaceName, - onlyCode $ "using namespace " ++ dynamicNamespaceName ++ ";", - onlyCode $ "#endif // " ++ dynamicNamespaceName + onlyCode $ "#ifdef " ++ publicNamespaceMacro, + onlyCode $ "} // namespace " ++ publicNamespaceMacro, + onlyCode $ "using namespace " ++ publicNamespaceMacro ++ ";", + onlyCode $ "#endif // " ++ publicNamespaceMacro ] + | isPrivateNamespace $ getCategoryNamespace t = mconcat [ + onlyCode $ "#ifdef " ++ privateNamespaceMacro, + onlyCode $ "namespace " ++ privateNamespaceMacro ++ " {", + onlyCode $ "#endif // " ++ privateNamespaceMacro, + cs, + onlyCode $ "#ifdef " ++ privateNamespaceMacro, + onlyCode $ "} // namespace " ++ privateNamespaceMacro, + onlyCode $ "using namespace " ++ privateNamespaceMacro ++ ";", + onlyCode $ "#endif // " ++ privateNamespaceMacro + ] | otherwise = cs createLabelForFunction :: Int -> ScopedFunction c -> String @@ -534,7 +586,7 @@ | s == CategoryScope = " using CallType = ReturnTuple(" ++ categoryName n ++ "::*)(const ParamTuple&, const ValueTuple&);" | s == TypeScope = " using CallType = ReturnTuple(" ++ typeName n ++ - "::*)(const ParamTuple&, const ValueTuple&);" + "::*)(const S&, const ParamTuple&, const ValueTuple&);" | s == ValueScope = " using CallType = ReturnTuple(" ++ valueName n ++ "::*)(const S&, const ParamTuple&, const ValueTuple&);" | otherwise = undefined @@ -557,37 +609,37 @@ ] args | s == CategoryScope = "params, args" - | s == TypeScope = "params, args" + | s == TypeScope = "self, params, args" | s == ValueScope = "self, params, args" | otherwise = undefined fallback | s == CategoryScope = " return TypeCategory::Dispatch(label, params, args);" - | s == TypeScope = " return TypeInstance::Dispatch(label, params, args);" + | s == TypeScope = " return TypeInstance::Dispatch(self, label, params, args);" | s == ValueScope = " return TypeValue::Dispatch(self, label, params, args);" | otherwise = undefined -commonDefineCategory :: MergeableM m => +commonDefineCategory :: CompileErrorM m => AnyCategory c -> CompiledData [String] -> m (CompiledData [String]) commonDefineCategory t extra = do - mergeAllM $ [ + concatM $ [ return $ onlyCode $ "struct " ++ categoryName name ++ " : public " ++ categoryBase ++ " {", - return $ indentCompiled $ defineCategoryName name, + return $ indentCompiled $ defineCategoryName CategoryScope name, return $ indentCompiled extra, return $ onlyCode "};" ] where name = getCategoryName t -commonDefineType :: MergeableM m => +commonDefineType :: CompileErrorM m => AnyCategory c -> Maybe [ValueRefine c] -> CompiledData [String] -> m (CompiledData [String]) commonDefineType t rs extra = do let rs' = case rs of Nothing -> getCategoryRefines t Just rs2 -> rs2 - mergeAllM [ + concatM [ return $ CompiledData depends [], return $ onlyCode $ "struct " ++ typeName (getCategoryName t) ++ " : public " ++ typeBase ++ " {", - return $ indentCompiled $ defineCategoryName2 name, + return $ indentCompiled $ defineCategoryName TypeScope name, return $ indentCompiled $ defineTypeName name (map vpParam $ getCategoryParams t), return $ indentCompiled $ onlyCode $ categoryName (getCategoryName t) ++ "& parent;", return $ indentCompiled createParams, @@ -599,15 +651,15 @@ where name = getCategoryName t depends = getCategoryDeps t - createParams = mergeAll $ map createParam $ getCategoryParams t + createParams = mconcat $ map createParam $ getCategoryParams t createParam p = onlyCode $ paramType ++ " " ++ paramName (vpParam p) ++ ";" canConvertFrom | isInstanceInterface t = emptyCode | otherwise = onlyCodes $ [ - "bool CanConvertFrom(const TypeInstance& from) const final {", + "bool CanConvertFrom(const S& from) const final {", -- TODO: This should be a typedef. - " std::vector args;", - " if (!from.TypeArgsForParent(parent, args)) return false;", + " std::vector> args;", + " if (!from->TypeArgsForParent(parent, args)) return false;", -- TODO: Create a helper function for this error. " if(args.size() != " ++ show (length params) ++ ") {", " FAIL() << \"Wrong number of args (\" << args.size() << \") for \" << CategoryName();", @@ -615,57 +667,48 @@ ] ++ checks ++ [" return true;","}"] params = map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t checks = concat $ map singleCheck $ zip ([0..] :: [Int]) 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;" - ] + singleCheck (i,(p,Covariant)) = [checkCov i p] + singleCheck (i,(p,Contravariant)) = [checkCon i p] + singleCheck (i,(p,Invariant)) = [checkCov i p,checkCon i p] + checkCov i p = " if (!TypeInstance::CanConvert(args[" ++ show i ++ "], " ++ paramName p ++ ")) return false;" + checkCon i p = " if (!TypeInstance::CanConvert(" ++ paramName p ++ ", args[" ++ show i ++ "])) return false;" typeArgsForParent rs2 | isInstanceInterface t = emptyCode | otherwise = onlyCodes $ [ "bool TypeArgsForParent(" ++ "const TypeCategory& category, " ++ - "std::vector& args) const final {" + "std::vector>& args) const final {" ] ++ allCats rs2 ++ [" return false;","}"] - myType = (getCategoryName t,map (SingleType . JustParamName False . fst) params) + myType = (getCategoryName t,map (singleType . JustParamName False . fst) params) refines rs2 = map (\r -> (tiName r,pValues $ tiParams r)) $ map vrType rs2 allCats rs2 = concat $ map singleCat (myType:refines rs2) singleCat (t2,ps) = [ " if (&category == &" ++ categoryGetter t2 ++ "()) {", - " args = std::vector{" ++ expanded ++ "};", + " args = std::vector>{" ++ expanded ++ "};", " return true;", " }" ] where - expanded = intercalate "," $ map ('&':) $ map expandLocalType ps + expanded = intercalate ", " $ 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 m ++ "(L_get<" ++ typeBase ++ "*>(" ++ intercalate "," (map ("&" ++) ps') ++ "))" - where - ps' = map expandLocalType ps - getter MergeUnion = unionGetter - getter 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 -expandLocalType _ = undefined -- The instance is an InferredType. - -defineCategoryName :: CategoryName -> CompiledData [String] -defineCategoryName t = onlyCode $ "std::string CategoryName() const final { return \"" ++ show t ++ "\"; }" +expandLocalType t + | t == minBound = allGetter ++ "()" + | t == maxBound = anyGetter ++ "()" +expandLocalType t = reduceMergeTree getAny getAll getSingle t where + getAny ts = unionGetter ++ combine ts + getAll ts = intersectGetter ++ combine ts + getSingle (JustTypeInstance (TypeInstance t2 ps)) = + typeGetter t2 ++ "(T_get(" ++ intercalate ", " (map expandLocalType $ pValues ps) ++ "))" + getSingle (JustParamName _ p) = paramName p + getSingle (JustInferredType p) = paramName p + combine ps = "(L_get<" ++ typeBase ++ "*>(" ++ intercalate "," (map ("&" ++) ps) ++ "))" -defineCategoryName2 :: CategoryName -> CompiledData [String] -defineCategoryName2 _ = onlyCode $ "std::string CategoryName() const final { return parent.CategoryName(); }" +defineCategoryName :: SymbolScope -> CategoryName -> CompiledData [String] +defineCategoryName TypeScope _ = onlyCode $ "std::string CategoryName() const final { return parent.CategoryName(); }" +defineCategoryName ValueScope _ = onlyCode $ "std::string CategoryName() const final { return parent->CategoryName(); }" +defineCategoryName _ t = onlyCode $ "std::string CategoryName() const final { return \"" ++ show t ++ "\"; }" defineTypeName :: CategoryName -> [ParamName] -> CompiledData [String] defineTypeName _ ps = @@ -686,12 +729,12 @@ ] declareGetType :: AnyCategory c -> [String] -declareGetType t = [typeBase ++ "& " ++ typeGetter (getCategoryName t) ++ "(Params<" ++ +declareGetType t = ["S<" ++ typeBase ++ "> " ++ typeGetter (getCategoryName t) ++ "(Params<" ++ show (length $getCategoryParams t) ++ ">::Type params);"] defineGetType :: AnyCategory c -> [String] defineGetType t = [ - typeBase ++ "& " ++ typeGetter (getCategoryName t) ++ "(Params<" ++ + "S<" ++ typeBase ++ "> " ++ typeGetter (getCategoryName t) ++ "(Params<" ++ show (length $ getCategoryParams t) ++ ">::Type params) {", " return " ++ typeCreator (getCategoryName t) ++ "(params);", "}" @@ -710,7 +753,7 @@ declareInternalType :: Monad m => CategoryName -> Int -> m (CompiledData [String]) declareInternalType t n = - return $ onlyCode $ typeName t ++ "& " ++ typeCreator t ++ + return $ onlyCode $ "S<" ++ typeName t ++ "> " ++ typeCreator t ++ "(Params<" ++ show n ++ ">::Type params);" defineInternalType :: Monad m => @@ -718,20 +761,21 @@ defineInternalType t n | n < 1 = return $ onlyCodes [ - typeName t ++ "& " ++ typeCreator t ++ "(Params<" ++ show n ++ ">::Type params) {", - " static auto& cached = *new " ++ typeName t ++ "(" ++ categoryCreator t ++ "(), Params<" ++ show n ++ ">::Type());", + "S<" ++ typeName t ++ "> " ++ typeCreator t ++ "(Params<" ++ show n ++ ">::Type params) {", + " static const auto cached = S_get(new " ++ typeName t ++ "(" ++ categoryCreator t ++ "(), Params<" ++ show n ++ ">::Type()));", " return cached;", "}" ] | otherwise = return $ onlyCodes [ - typeName t ++ "& " ++ typeCreator t ++ "(Params<" ++ show n ++ ">::Type params) {", - " static auto& cache = *new InstanceMap<" ++ show n ++ "," ++ typeName t ++ ">();", + "S<" ++ typeName t ++ "> " ++ typeCreator t ++ "(Params<" ++ show n ++ ">::Type params) {", + " static auto& cache = *new WeakInstanceMap<" ++ show n ++ ", " ++ typeName t ++ ">();", " static auto& cache_mutex = *new std::mutex;", " std::lock_guard lock(cache_mutex);", - " auto& cached = cache[params];", - " if (!cached) { cached = R_get(new " ++ typeName t ++ "(" ++ categoryCreator t ++ "(), params)); }", - " return *cached;", + " auto& cached = cache[GetKeyFromParams<" ++ show n ++ ">(params)];", + " S<" ++ typeName t ++ "> type = cached;", + " if (!type) { cached = type = S_get(new " ++ typeName t ++ "(" ++ categoryCreator t ++ "(), params)); }", + " return type;", "}" ] @@ -740,7 +784,7 @@ declareInternalValue t _ _ = return $ onlyCodes [ "S " ++ valueCreator t ++ - "(" ++ typeName t ++ "& parent, " ++ + "(S<" ++ typeName t ++ "> parent, " ++ "const ParamTuple& params, const ValueTuple& args);" ] @@ -748,7 +792,7 @@ CategoryName -> Int -> Int -> m (CompiledData [String]) defineInternalValue t _ _ = return $ onlyCodes [ - "S " ++ valueCreator t ++ "(" ++ typeName t ++ "& parent, " ++ + "S " ++ valueCreator t ++ "(S<" ++ typeName t ++ "> parent, " ++ "const ParamTuple& params, const ValueTuple& args) {", " return S_get(new " ++ valueName t ++ "(parent, params, args));", "}" @@ -765,22 +809,22 @@ depIncludes req2 = map (\i -> "#include \"" ++ headerFilename i ++ "\"") $ Set.toList req2 -createMainFile :: (Show c, CompileErrorM m, MergeableM m) => +createMainFile :: (Show c, CompileErrorM m) => CategoryMap c -> ExprMap c -> CategoryName -> FunctionName -> m (Namespace,[String]) createMainFile tm em n f = ("In the creation of the main binary procedure") ??> do ca <- fmap indentCompiled (compileMainProcedure tm em expr) - let file = createMainCommon "main" ca + let file = noTestsOnlySourceGuard ++ 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) => +createTestFile :: (Show c, CompileErrorM m) => CategoryMap c -> ExprMap c -> Expression c -> m ([CategoryName],[String]) createTestFile tm em e = ("In the creation of the test binary procedure") ??> do ca@(CompiledData req _) <- fmap indentCompiled (compileMainProcedure tm em e) - let file = createMainCommon "test" ca + let file = testsOnlySourceGuard ++ createMainCommon "test" ca return (Set.toList req,file) getCategoryMentions :: AnyCategory c -> [CategoryName] @@ -795,6 +839,6 @@ fromFunction (ScopedFunction _ _ t2 _ as rs _ fs _) = [t2] ++ (fromGenerals $ map (vtType . pvType) (pValues as ++ pValues rs)) ++ fromFilters fs fromFilters fs = concat $ map (fromFilter . pfFilter) fs - fromFilter (TypeFilter _ t2) = Set.toList $ categoriesFromTypes $ SingleType t2 + fromFilter (TypeFilter _ t2) = Set.toList $ categoriesFromTypes t2 fromFilter (DefinesFilter t2) = fromDefine t2 fromGenerals = Set.toList . Set.unions . map categoriesFromTypes diff --git a/src/CompilerCxx/CategoryContext.hs b/src/CompilerCxx/CategoryContext.hs --- a/src/CompilerCxx/CategoryContext.hs +++ b/src/CompilerCxx/CategoryContext.hs @@ -29,7 +29,6 @@ import qualified Data.Set as Set import Base.CompileError -import Base.Mergeable import Compilation.CompilerState import Compilation.ProcedureContext import Compilation.ScopeContext @@ -42,7 +41,7 @@ import Types.TypeInstance -getContextForInit :: (Show c, CompileErrorM m, MergeableM m) => +getContextForInit :: (Show c, CompileErrorM m) => CategoryMap c -> ExprMap c -> AnyCategory c -> DefinedCategory c -> SymbolScope -> m (ProcedureContext c) getContextForInit tm em t d s = do @@ -55,7 +54,8 @@ 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 False . vpParam) ps + fm <- getFilterMap (pValues ps) pa + let typeInstance = TypeInstance (getCategoryName t) $ fmap (singleType . JustParamName False . vpParam) ps let builtin = Map.filter ((== LocalScope) . vvScope) $ builtinVariables typeInstance members <- mapMembers $ filter ((<= s) . dmScope) (dcMembers d) return $ ProcedureContext { @@ -65,7 +65,7 @@ pcIntParams = Positional [], pcMembers = ms, pcCategories = tm, - pcAllFilters = getFilterMap (pValues ps) pa, + pcAllFilters = fm, pcExtFilters = pa, pcIntFilters = [], pcParamScopes = sa, @@ -85,7 +85,7 @@ pcNoTrace = False } -getProcedureContext :: (Show c, CompileErrorM m, MergeableM m) => +getProcedureContext :: (Show c, CompileErrorM m) => ScopeContext c -> ScopedFunction c -> ExecutableProcedure c -> m (ProcedureContext c) getProcedureContext (ScopeContext tm t ps pi ms pa fi fa va em) ff@(ScopedFunction _ _ _ s as1 rs1 ps1 fs _) @@ -106,9 +106,9 @@ TypeScope -> Map.union typeScopes localScopes ValueScope -> Map.unions [localScopes,typeScopes,valueScopes] _ -> undefined - let localFilters = getFunctionFilterMap ff - let typeFilters = getFilterMap (pValues ps) pa - let valueFilters = getFilterMap (pValues pi) fi + localFilters <- getFunctionFilterMap ff + typeFilters <- getFilterMap (pValues ps) pa + valueFilters <- getFilterMap (pValues pi) fi let allFilters = case s of CategoryScope -> localFilters TypeScope -> Map.union localFilters typeFilters diff --git a/src/CompilerCxx/Code.hs b/src/CompilerCxx/Code.hs --- a/src/CompilerCxx/Code.hs +++ b/src/CompilerCxx/Code.hs @@ -31,6 +31,7 @@ indentCompiled, isPrimType, newFunctionLabel, + noTestsOnlySourceGuard, onlyCode, onlyCodes, paramType, @@ -40,6 +41,8 @@ showCreationTrace, startCleanupTracing, startFunctionTracing, + testsOnlyCategoryGuard, + testsOnlySourceGuard, typeBase, useAsArgs, useAsReturns, @@ -313,7 +316,7 @@ valueBase = "TypeValue" paramType :: String -paramType = typeBase ++ "&" +paramType = "const S<" ++ typeBase ++ ">" unescapedChars :: Set.Set Char unescapedChars = Set.fromList $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ [' ','.'] @@ -343,3 +346,36 @@ maybeQuote ss | null ss = "" | otherwise = "\"" ++ ss ++ "\"" + +testsOnlyMacro :: String +testsOnlyMacro = "ZEOLITE_TESTS_ONLY__YOUR_MODULE_IS_BROKEN_IF_YOU_USE_THIS_IN_HAND_WRITTEN_CODE" + +noTestsOnlyMacro :: String +noTestsOnlyMacro = "ZEOLITE_NO_TESTS_ONLY__YOUR_MODULE_IS_BROKEN_IF_YOU_USE_THIS_IN_HAND_WRITTEN_CODE" + +testsOnlyCategoryGuard :: CategoryName -> [String] +testsOnlyCategoryGuard n = [ + "#ifndef " ++ testsOnlyMacro, + "#error Category " ++ show n ++ " can only be used by $TestsOnly$ categories", + "#endif // " ++ testsOnlyMacro + ] + +testsOnlySourceGuard :: [String] +testsOnlySourceGuard = [ + "#ifndef " ++ testsOnlyMacro, + "#define " ++ testsOnlyMacro, + "#endif // " ++ testsOnlyMacro, + "#ifdef " ++ noTestsOnlyMacro, + "#error Cannot define both $TestsOnly$ and non-$TestsOnly$ categories in the same source file", + "#endif // " ++ noTestsOnlyMacro + ] + +noTestsOnlySourceGuard :: [String] +noTestsOnlySourceGuard = [ + "#ifndef " ++ noTestsOnlyMacro, + "#define " ++ noTestsOnlyMacro, + "#endif // " ++ noTestsOnlyMacro, + "#ifdef " ++ testsOnlyMacro, + "#error Cannot define both $TestsOnly$ and non-$TestsOnly$ categories in the same source file", + "#endif // " ++ testsOnlyMacro + ] diff --git a/src/CompilerCxx/Naming.hs b/src/CompilerCxx/Naming.hs --- a/src/CompilerCxx/Naming.hs +++ b/src/CompilerCxx/Naming.hs @@ -28,18 +28,21 @@ categoryGetter, categoryName, collectionName, - dynamicNamespaceName, functionName, headerFilename, + headerStreamlined, initializerName, intersectGetter, mainFilename, mainSourceIncludes, paramName, privateNamespace, + privateNamespaceMacro, publicNamespace, + publicNamespaceMacro, qualifiedTypeGetter, sourceFilename, + sourceStreamlined, tableName, testFilename, typeCreator, @@ -65,6 +68,12 @@ sourceFilename :: CategoryName -> String sourceFilename n = "Category_" ++ show n ++ ".cpp" +headerStreamlined :: CategoryName -> String +headerStreamlined n = "Streamlined_" ++ show n ++ ".hpp" + +sourceStreamlined :: CategoryName -> String +sourceStreamlined n = "Streamlined_" ++ show n ++ ".cpp" + mainFilename :: String mainFilename = "main.cpp" @@ -149,5 +158,8 @@ show (getCategoryNamespace t) ++ "::" ++ (typeGetter $ getCategoryName t) | otherwise = typeGetter $ getCategoryName t -dynamicNamespaceName :: String -dynamicNamespaceName = "ZEOLITE_DYNAMIC_NAMESPACE" +publicNamespaceMacro :: String +publicNamespaceMacro = "ZEOLITE_PUBLIC_NAMESPACE" + +privateNamespaceMacro :: String +privateNamespaceMacro = "ZEOLITE_PRIVATE_NAMESPACE" diff --git a/src/CompilerCxx/Procedure.hs b/src/CompilerCxx/Procedure.hs --- a/src/CompilerCxx/Procedure.hs +++ b/src/CompilerCxx/Procedure.hs @@ -40,7 +40,7 @@ import qualified Data.Set as Set import Base.CompileError -import Base.Mergeable +import Base.MergeTree import Compilation.CompilerState import Compilation.ProcedureContext (ExprMap) import Compilation.ScopeContext @@ -56,9 +56,10 @@ import Types.Procedure import Types.TypeCategory import Types.TypeInstance +import Types.Variance -compileExecutableProcedure :: (Show c, CompileErrorM m, MergeableM m) => +compileExecutableProcedure :: (Show c, CompileErrorM m) => ScopeContext c -> ScopedFunction c -> ExecutableProcedure c -> m (CompiledData [String],CompiledData [String]) compileExecutableProcedure ctx ff@(ScopedFunction _ _ _ s as1 rs1 ps1 _ _) @@ -78,7 +79,7 @@ doImplicitReturn [] & self, const ParamTuple& params, const ValueTuple& args);" | s == ValueScope = returnType ++ " " ++ name ++ "(const S& Var_self, const ParamTuple& params, const ValueTuple& args);" - | otherwise = - returnType ++ " " ++ name ++ "(const ParamTuple& params, const ValueTuple& args);" + | otherwise = undefined 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) {" + returnType ++ " " ++ typeName t ++ "::" ++ name ++ + -- NOTE: Don't use Var_self, since self isn't accessible to @type functions. + "(const S& self, const ParamTuple& params, const ValueTuple& args) {" | s == ValueScope = returnType ++ " " ++ valueName t ++ "::" ++ name ++ "(const S& Var_self, const ParamTuple& params, const ValueTuple& args) {" @@ -120,7 +128,7 @@ | isUnnamedReturns rs2 = [] | otherwise = [returnType ++ " returns(" ++ show (length $ pValues rs1) ++ ");"] nameParams = flip map (zip ([0..] :: [Int]) $ pValues ps1) $ - (\(i,p2) -> paramType ++ " " ++ paramName (vpParam p2) ++ " = *params.At(" ++ show i ++ ");") + (\(i,p2) -> paramType ++ " " ++ paramName (vpParam p2) ++ " = params.At(" ++ show i ++ ");") nameArgs = flip map (zip ([0..] :: [Int]) $ filter (not . isDiscardedInput . snd) $ zip (pValues as1) (pValues $ avNames as2)) $ (\(i,(t2,n2)) -> "const " ++ variableProxyType (pvType t2) ++ " " ++ variableName (ivName n2) ++ " = " ++ writeStoredVariable (pvType t2) (UnwrappedSingle $ "args.At(" ++ show i ++ ")") ++ ";") @@ -133,7 +141,7 @@ variableProxyType t2 ++ " " ++ variableName (ovName n2) ++ " = " ++ writeStoredVariable t2 (UnwrappedSingle $ "returns.At(" ++ show i ++ ")") ++ ";" -compileCondition :: (Show c, CompileErrorM m, MergeableM m, +compileCondition :: (Show c, CompileErrorM m, CompilerContext c m [String] a) => a -> [c] -> Expression c -> CompilerState a m String compileCondition ctx c e = do @@ -155,7 +163,7 @@ 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, +compileProcedure :: (Show c, CompileErrorM m, CompilerContext c m [String] a) => a -> Procedure c -> CompilerState a m a compileProcedure ctx (Procedure _ ss) = do @@ -171,14 +179,14 @@ s' <- resetBackgroundStateT $ compileStatement s return s' -maybeSetTrace :: (Show c, CompileErrorM m, MergeableM m, +maybeSetTrace :: (Show c, CompileErrorM m, CompilerContext c m [String] a) => [c] -> CompilerState a m () maybeSetTrace c = do noTrace <- csGetNoTrace when (not noTrace) $ csWrite $ setTraceContext c -compileStatement :: (Show c, CompileErrorM m, MergeableM m, +compileStatement :: (Show c, CompileErrorM m, CompilerContext c m [String] a) => Statement c -> CompilerState a m () compileStatement (EmptyReturn c) = do @@ -195,7 +203,7 @@ autoPositionalCleanup e -- Multi-expression => must all be singles. getReturn rs = do - lift $ mergeAllM (map checkArity $ zip ([0..] :: [Int]) $ map (fst . snd) rs) do -- TODO: Call csRequiresTypes for t1. (Maybe needs a helper function.) - lift $ mergeAllM [validateGeneralInstance r fa (vtType t1), - checkValueTypeMatch_ r fa t2 t1] + lift $ collectAllM_ [validateGeneralInstance r fa (vtType t1), + checkValueAssignment r fa t2 t1] csAddVariable c2 n (VariableValue c2 LocalScope t1 True) csWrite [variableStoredType t1 ++ " " ++ variableName n ++ ";"] createVariable r fa (ExistingVariable (InputValue c2 n)) t2 = @@ -278,7 +286,7 @@ when (not w) $ lift $ compileErrorM $ "Cannot assign to read-only variable " ++ show n ++ formatFullContextBrace c2 -- TODO: Also show original context. - lift $ (checkValueTypeMatch_ r fa t2 t1) + lift $ (checkValueAssignment r fa t2 t1) csUpdateAssigned n createVariable _ _ _ _ = return () assignSingle (_,t,CreateVariable _ _ n) e2 = @@ -299,19 +307,19 @@ assignMulti _ = return () compileStatement (NoValueExpression _ v) = compileVoidExpression v -compileRegularInit :: (Show c, CompileErrorM m, MergeableM m, +compileRegularInit :: (Show c, CompileErrorM m, CompilerContext c m [String] a) => DefinedMember c -> CompilerState a m () -compileRegularInit (DefinedMember _ _ _ _ Nothing) = return mergeDefault +compileRegularInit (DefinedMember _ _ _ _ Nothing) = return () compileRegularInit (DefinedMember c2 s t n2 (Just e)) = resetBackgroundStateT $ do csAddVariable c2 n2 (VariableValue c2 s t True) let assign = Assignment c2 (Positional [ExistingVariable (InputValue c2 n2)]) e compileStatement assign -compileLazyInit :: (Show c, CompileErrorM m, MergeableM m, +compileLazyInit :: (Show c, CompileErrorM m, CompilerContext c m [String] a) => DefinedMember c -> CompilerState a m () -compileLazyInit (DefinedMember _ _ _ _ Nothing) = return mergeDefault +compileLazyInit (DefinedMember _ _ _ _ Nothing) = return () compileLazyInit (DefinedMember c _ t1 n (Just e)) = resetBackgroundStateT $ do (ts,e') <- compileExpression e when (length (pValues ts) /= 1) $ @@ -319,11 +327,11 @@ r <- csResolver fa <- csAllFilters let Positional [t2] = ts - lift $ (checkValueTypeMatch_ r fa t2 t1) VoidExpression c -> CompilerState a m () compileVoidExpression (Conditional ie) = compileIfElifElse ie @@ -339,7 +347,7 @@ csWrite ["}"] csInheritReturns [ctx] -compileIfElifElse :: (Show c, CompileErrorM m, MergeableM m, +compileIfElifElse :: (Show c, CompileErrorM m, CompilerContext c m [String] a) => IfElifElse c -> CompilerState a m () compileIfElifElse (IfStatement c e p es) = do @@ -374,7 +382,7 @@ unwind TerminateConditional = fmap (:[]) get compileIfElifElse _ = undefined -compileWhileLoop :: (Show c, CompileErrorM m, MergeableM m, +compileWhileLoop :: (Show c, CompileErrorM m, CompilerContext c m [String] a) => WhileLoop c -> CompilerState a m () compileWhileLoop (WhileLoop c e p u) = do @@ -396,7 +404,7 @@ csWrite $ ["{"] ++ u' ++ ["}"] csWrite ["}"] -compileScopedBlock :: (Show c, CompileErrorM m, MergeableM m, +compileScopedBlock :: (Show c, CompileErrorM m, CompilerContext c m [String] a) => ScopedBlock c -> CompilerState a m () compileScopedBlock s = do @@ -416,9 +424,9 @@ lift $ ccInheritReturns ctxP0 [ctxS0'] (ctxP,cl',ctxCl) <- case cl of - Just p2 -> do + Just p2@(Procedure c _) -> do ctxCl0' <- lift $ ccStartCleanup ctxCl0 - ctxCl <- compileProcedure ctxCl0' p2 + ctxCl <- compileProcedure ctxCl0' p2 Expression c -> CompilerState a m (ExpressionType,ExprValue) compileExpression = compile where @@ -530,11 +538,11 @@ | o == "-" = doNeg t e2 | o == "~" = doComp t e2 | otherwise = lift $ compileErrorM $ "Unknown unary operator \"" ++ o ++ "\" " ++ - formatFullContextBrace c + formatFullContextBrace c doNot t e2 = do when (t /= boolRequiredValue) $ lift $ compileErrorM $ "Cannot use " ++ show t ++ " with unary ! operator" ++ - formatFullContextBrace c + formatFullContextBrace c return $ (Positional [boolRequiredValue],UnboxedPrimitive PrimBool $ "!" ++ useAsUnboxed PrimBool e2) doNeg t e2 | t == intRequiredValue = return $ (Positional [intRequiredValue], @@ -542,15 +550,15 @@ | t == floatRequiredValue = return $ (Positional [floatRequiredValue], UnboxedPrimitive PrimFloat $ "-" ++ useAsUnboxed PrimFloat e2) | otherwise = lift $ compileErrorM $ "Cannot use " ++ show t ++ " with unary - operator" ++ - formatFullContextBrace c + formatFullContextBrace c doComp t e2 | t == intRequiredValue = return $ (Positional [intRequiredValue], UnboxedPrimitive PrimInt $ "~" ++ useAsUnboxed PrimInt e2) | otherwise = lift $ compileErrorM $ "Cannot use " ++ show t ++ " with unary ~ operator" ++ - formatFullContextBrace c + formatFullContextBrace c compile (InitializeValue c t ps es) = do es' <- sequence $ map compileExpression $ pValues es - (ts,es'') <- getValues es' + (ts,es'') <- lift $ getValues es' csCheckValueInit c t (Positional ts) ps params <- expandParams $ tiParams t params2 <- expandParams2 $ ps @@ -558,17 +566,16 @@ 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], + 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 ++ ")" + 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 ([0..] :: [Int]) $ map fst rs) ValueType -> FunctionCall c -> CompilerState a m (ScopedFunction c) lookupValueFunction (ValueType WeakValue t) (FunctionCall c _ _ _) = @@ -676,7 +683,7 @@ lookupValueFunction (ValueType RequiredValue t) (FunctionCall c n _ _) = csGetTypeFunction c (Just t) n -compileExpressionStart :: (Show c, CompileErrorM m, MergeableM m, +compileExpressionStart :: (Show c, CompileErrorM m, CompilerContext c m [String] a) => ExpressionStart c -> CompilerState a m (ExpressionType,ExprValue) compileExpressionStart (NamedVariable (OutputValue c n)) = do @@ -696,18 +703,18 @@ compileExpressionStart (TypeCall c t f@(FunctionCall _ n _ _)) = do r <- csResolver fa <- csAllFilters - lift $ validateGeneralInstance r fa (SingleType t) t2 then just return e without a Reduce call. t1' <- expandGeneralInstance t1 @@ -805,7 +812,7 @@ (Positional [t],e') <- compileExpression e -- TODO: Get rid of the Positional matching here. r <- csResolver fa <- csAllFilters - lift $ (checkValueTypeMatch_ r fa t t0) Maybe String -> ScopedFunction c -> FunctionCall c -> CompilerState a m (ExpressionType,ExprValue) -compileFunctionCall e f (FunctionCall c _ ps es) = errorContext ???> do +compileFunctionCall e f (FunctionCall c _ ps es) = message ???> do r <- csResolver fa <- csAllFilters es' <- sequence $ map compileExpression $ pValues es - (ts,es'') <- getValues es' + (ts,es'') <- lift $ getValues es' ps2 <- lift $ guessParamsFromArgs r fa f ps (Positional ts) - lift $ mergeAllM $ map backgroundMessage $ zip3 (map vpParam $ pValues $ sfParams f) (pValues ps) (pValues ps2) + lift $ mapErrorsM_ backgroundMessage $ zip3 (map vpParam $ pValues $ sfParams f) (pValues ps) (pValues ps2) f' <- lift $ parsedToFunctionType f f'' <- lift $ assignFunctionParams r fa Map.empty ps2 f' -- Called an extra time so arg count mismatches have reasonable errors. @@ -838,45 +845,54 @@ csRequiresTypes $ Set.unions $ map categoriesFromTypes $ pValues ps2 csRequiresTypes (Set.fromList [sfType f]) params <- expandParams2 ps2 + scope <- csCurrentScope scoped <- autoScope (sfScope f) - call <- assemble e scoped (sfScope f) params es'' + call <- assemble e scoped scope (sfScope f) params es'' return $ (ftReturns f'',OpaqueMulti call) where - errorContext = "In call to " ++ show (sfName f) ++ " at " ++ formatFullContext c + message = "In call to " ++ show (sfName f) ++ " at " ++ formatFullContext c backgroundMessage (n,(InferredInstance c2),t) = compileBackgroundM $ "Parameter " ++ show n ++ " (from " ++ show (sfType f) ++ "." ++ show (sfName f) ++ ") inferred as " ++ show t ++ " at " ++ formatFullContext c2 backgroundMessage _ = return () - assemble Nothing _ ValueScope ps2 es2 = + assemble Nothing _ ValueScope ValueScope ps2 es2 = return $ callName (sfName f) ++ "(Var_self, " ++ ps2 ++ ", " ++ es2 ++ ")" - assemble Nothing scoped _ ps2 es2 = + assemble Nothing _ TypeScope TypeScope ps2 es2 = + return $ callName (sfName f) ++ "(self, " ++ ps2 ++ ", " ++ es2 ++ ")" + assemble Nothing _ ValueScope TypeScope ps2 es2 = + return $ typeBase ++ "::Call(parent, " ++ functionName f ++ ", " ++ ps2 ++ ", " ++ es2 ++ ")" + assemble Nothing scoped _ _ ps2 es2 = return $ scoped ++ callName (sfName f) ++ "(" ++ ps2 ++ ", " ++ es2 ++ ")" - assemble (Just e2) _ ValueScope ps2 es2 = + assemble (Just e2) _ _ ValueScope ps2 es2 = return $ valueBase ++ "::Call(" ++ e2 ++ ", " ++ functionName f ++ ", " ++ ps2 ++ ", " ++ es2 ++ ")" - assemble (Just e2) _ _ ps2 es2 = + assemble (Just e2) _ _ TypeScope ps2 es2 = + return $ typeBase ++ "::Call(" ++ e2 ++ ", " ++ functionName f ++ ", " ++ ps2 ++ ", " ++ es2 ++ ")" + assemble (Just e2) _ _ _ ps2 es2 = return $ e2 ++ ".Call(" ++ functionName f ++ ", " ++ ps2 ++ ", " ++ es2 ++ ")" -- TODO: Lots of duplication with assignments and initialization. -- Single expression, but possibly multi-return. getValues [(Positional ts,e2)] = return (ts,useAsArgs e2) -- Multi-expression => must all be singles. getValues rs = do - lift $ mergeAllM (map checkArity $ zip ([0..] :: [Int]) $ map fst rs) +guessParamsFromArgs :: (Show c, CompileErrorM m, TypeResolver r) => r -> ParamFilters -> ScopedFunction c -> Positional (InstanceOrInferred c) -> Positional ValueType -> m (Positional GeneralInstance) guessParamsFromArgs r fa f ps ts = do - let ff = getFunctionFilterMap f - args <- processPairs alwaysPair ts (fmap pvType $ sfArgs f) + fm <- getFunctionFilterMap f + args <- processPairs (\t1 t2 -> return $ PatternMatch Covariant t1 t2) ts (fmap pvType $ sfArgs f) pa <- fmap Map.fromList $ processPairs toInstance (fmap vpParam $ sfParams f) ps - pa3 <- inferParamTypes r fa ff pa args + gs <- inferParamTypes r fa pa args + gs' <- mergeInferredTypes r fa fm pa gs + let pa3 = guessesAsParams gs' `Map.union` pa fmap Positional $ mapErrorsM (subPosition pa3) (pValues $ sfParams f) where subPosition pa2 p = case (vpParam p) `Map.lookup` pa2 of @@ -884,9 +900,9 @@ Nothing -> compileErrorM $ "Something went wrong inferring " ++ show (vpParam p) ++ formatFullContextBrace (vpContext p) toInstance p1 (AssignedInstance _ t) = return (p1,t) - toInstance p1 (InferredInstance _) = return (p1,SingleType $ JustInferredType p1) + toInstance p1 (InferredInstance _) = return (p1,singleType $ JustInferredType p1) -compileMainProcedure :: (Show c, CompileErrorM m, MergeableM m) => +compileMainProcedure :: (Show c, CompileErrorM m) => CategoryMap c -> ExprMap c -> Expression c -> m (CompiledData [String]) compileMainProcedure tm em e = do ctx <- getMainContext tm em @@ -896,23 +912,23 @@ ctx0 <- getCleanContext compileProcedure ctx0 procedure >>= put -autoScope :: (CompilerContext c m s a) => +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 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 _ = [] +categoriesFromTypes = reduceMergeTree Set.unions Set.unions getAll where + getAll (JustTypeInstance (TypeInstance t ps)) = + t `Set.insert` (Set.unions $ map categoriesFromTypes $ pValues ps) + getAll _ = Set.empty categoriesFromRefine :: TypeInstance -> Set.Set CategoryName categoriesFromRefine (TypeInstance t ps) = t `Set.insert` (Set.unions $ map categoriesFromTypes $ pValues ps) @@ -924,36 +940,37 @@ Positional GeneralInstance -> CompilerState a m String expandParams ps = do ps' <- sequence $ map expandGeneralInstance $ pValues ps - return $ "T_get(" ++ intercalate "," (map ("&" ++) ps') ++ ")" + return $ "T_get(" ++ intercalate ", " ps' ++ ")" expandParams2 :: (CompileErrorM m, 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') ++ ")" + return $ "ParamTuple(" ++ intercalate "," ps' ++ ")" -expandCategory :: (CompilerContext c m s a) => +expandCategory :: CompilerContext c m s a => CategoryName -> CompilerState a m String expandCategory t = return $ categoryGetter t ++ "()" expandGeneralInstance :: (CompileErrorM m, 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 m ++ "(L_get<" ++ typeBase ++ "*>(" ++ intercalate "," (map ("&" ++) ps') ++ "))" - where - getter MergeUnion = unionGetter - getter 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 -expandGeneralInstance t = lift $ compileErrorM $ "Type " ++ show t ++ " contains unresolved types" +expandGeneralInstance t + | t == minBound = return $ allGetter ++ "()" + | t == maxBound = return $ anyGetter ++ "()" +expandGeneralInstance t = reduceMergeTree getAny getAll getSingle t where + getAny ts = combine ts >>= return . (unionGetter ++) + getAll ts = combine ts >>= return . (intersectGetter ++) + getSingle (JustTypeInstance (TypeInstance t2 ps)) = do + ps' <- sequence $ map expandGeneralInstance $ pValues ps + return $ typeGetter t2 ++ "(T_get(" ++ intercalate "," ps' ++ "))" + getSingle (JustParamName _ p) = do + s <- csGetParamScope p + scoped <- autoScope s + return $ scoped ++ paramName p + getSingle (JustInferredType p) = getSingle (JustParamName False p) + combine ps = do + ps' <- sequence ps + return $ "(L_get>(" ++ intercalate "," ps' ++ "))" doImplicitReturn :: (CompileErrorM m, Show c, CompilerContext c m [String] a) => [c] -> CompilerState a m () diff --git a/src/Config/LocalConfig.hs b/src/Config/LocalConfig.hs --- a/src/Config/LocalConfig.hs +++ b/src/Config/LocalConfig.hs @@ -77,25 +77,24 @@ compilerVersion = showVersion version instance CompilerBackend Backend where - runCxxCommand (UnixBackend cb co ab) (CompileToObject s p nm ns ps e) = do + runCxxCommand (UnixBackend cb co ab) (CompileToObject s p ms ps e) = do objName <- errorFromIO $ canonicalizePath $ p (takeFileName $ dropExtension s ++ ".o") - executeProcess cb $ co ++ otherOptions ++ ["-c", s, "-o", objName] + executeProcess cb (co ++ otherOptions ++ ["-c", s, "-o", objName]) (takeFileName $ dropExtension s ++ ".a") - executeProcess ab ["-q",arName,objName] + executeProcess ab ["-q",arName,objName] other where @@ -316,8 +322,8 @@ f <- parseQuoted return (OtherSource f) writeConfig (CategorySource f cs ds) = do - _ <- mapErrorsM validateCategoryName cs - _ <- mapErrorsM validateCategoryName ds + mapErrorsM_ validateCategoryName cs + mapErrorsM_ validateCategoryName ds return $ [ "category_source {", indent ("source: " ++ show f), diff --git a/src/Module/ProcessMetadata.hs b/src/Module/ProcessMetadata.hs --- a/src/Module/ProcessMetadata.hs +++ b/src/Module/ProcessMetadata.hs @@ -99,7 +99,7 @@ filePresent <- errorFromIO $ doesFileExist f when (not filePresent) $ compileErrorM $ "Module \"" ++ p ++ "\" has not been configured yet" c <- errorFromIO $ readFile f - (autoReadConfig f c) ForceMode -> FilePath -> CompileInfoIO Bool @@ -107,9 +107,9 @@ m <- errorFromIO $ toCompileInfo $ loadDepsCommon f h Map.empty Set.empty (\m2 -> cmPublicDeps m2 ++ cmPrivateDeps m2) [p] return $ not $ isCompileError m -isPathConfigured :: FilePath -> CompileInfoIO Bool -isPathConfigured p = do - m <- errorFromIO $ toCompileInfo $ loadRecompile p +isPathConfigured :: FilePath -> FilePath -> CompileInfoIO Bool +isPathConfigured p d = do + m <- errorFromIO $ toCompileInfo $ loadRecompile (p d) return $ not $ isCompileError m writeMetadata :: FilePath -> CompileMetadata -> CompileInfoIO () @@ -166,9 +166,9 @@ getExprMap :: FilePath -> ModuleConfig -> CompileInfoIO (ExprMap SourcePos) getExprMap p m = do - path <- errorFromIO $ canonicalizePath (p rmRoot m rmPath m) + path <- errorFromIO $ canonicalizePath (p mcRoot m mcPath m) let defaults = [("MODULE_PATH",Literal (StringLiteral [] path))] - return $ Map.fromList $ rmExprMap m ++ defaults + return $ Map.fromList $ mcExprMap m ++ defaults getRealPathsForDeps :: [CompileMetadata] -> [FilePath] getRealPathsForDeps = map cmPath @@ -178,10 +178,10 @@ extract m = map (cmPath m ) (cmPublicFiles m) getNamespacesForDeps :: [CompileMetadata] -> [Namespace] -getNamespacesForDeps = filter (not . isNoNamespace) . map cmNamespace +getNamespacesForDeps = filter (not . isNoNamespace) . map cmPublicNamespace getIncludePathsForDeps :: [CompileMetadata] -> [FilePath] -getIncludePathsForDeps = concat . map cmSubdirs +getIncludePathsForDeps = concat . map cmPublicSubdirs getLinkFlagsForDeps :: [CompileMetadata] -> [String] getLinkFlagsForDeps = concat . map cmLinkFlags @@ -213,13 +213,14 @@ (CompileMetadata -> [FilePath]) -> [FilePath] -> CompileInfoIO [CompileMetadata] loadDepsCommon f h ca pa0 getDeps ps = do (_,processed) <- fixedPaths >>= collect (pa0,[]) - mapErrorsM check processed where + let cached = Map.union ca (Map.fromList processed) + mapErrorsM (check cached) processed where enforce = f /= ForceAll fixedPaths = mapM (errorFromIO . canonicalizePath) ps collect xa@(pa,xs) (p:ps2) | p `Set.member` pa = collect xa ps2 | otherwise = do - let continue m ds = collect (p `Set.insert` pa,xs ++ [m]) (ps2 ++ ds) + let continue m ds = collect (p `Set.insert` pa,xs ++ [(p,m)]) (ps2 ++ ds) case p `Map.lookup` ca of Just m2 -> continue m2 [] Nothing -> do @@ -228,15 +229,17 @@ let ds = getDeps m2 continue m2 ds collect xa _ = return xa - check m - | cmPath m `Map.member` ca = return m + check cm (p,m) + | p `Map.member` ca = return m | otherwise = do - fresh <- checkModuleFreshness (cmPath m) m - let sameVersion = checkModuleVersionHash h m - when (enforce && not fresh) $ - compileErrorM $ "Module \"" ++ cmPath m ++ "\" is out of date and should be recompiled" - when (enforce && not sameVersion) $ - compileErrorM $ "Module \"" ++ cmPath m ++ "\" was compiled with a different compiler setup" + p' <- errorFromIO $ canonicalizePath p + when (cmPath m /= p') $ + compileErrorM $ "Module \"" ++ p ++ "\" has an invalid cache path and must be recompiled" + fresh <- errorFromIO $ toCompileInfo $ checkModuleFreshness h cm p m FilePath -> CompileInfoIO CompileMetadata @@ -253,7 +256,7 @@ filePresent <- errorFromIO $ doesFileExist f when (not filePresent) $ compileErrorM $ "Module \"" ++ p ++ "\" has not been compiled yet" c <- errorFromIO $ readFile f - (autoReadConfig f c) ([FilePath],[FilePath],[FilePath]) @@ -270,41 +273,52 @@ checkModuleVersionHash :: VersionHash -> CompileMetadata -> Bool checkModuleVersionHash h m = cmVersionHash m == h -checkModuleFreshness :: FilePath -> CompileMetadata -> CompileInfoIO Bool -checkModuleFreshness p (CompileMetadata _ p2 _ is is2 _ _ _ ps xs ts hxx cxx bs _ _) = do +checkModuleFreshness :: VersionHash -> MetadataMap -> FilePath -> CompileMetadata -> CompileInfoIO () +checkModuleFreshness h ca p m@(CompileMetadata _ p2 _ _ is is2 _ _ _ _ ps xs ts hxx cxx bs _ os) = do time <- errorFromIO $ 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 <- checkInput time (p moduleFilename) - f1 <- mapErrorsM (\p3 -> checkInput time $ getCachedPath p3 "" metadataFilename) $ is ++ is2 - f2 <- mapErrorsM (checkInput time . (p2 )) $ ps ++ xs - f3 <- mapErrorsM (checkInput time . getCachedPath p2 "") $ hxx ++ cxx - f4 <- mapErrorsM checkOutput bs - let fresh = not $ any id $ [rm,e1,e2,e3] ++ f1 ++ f2 ++ f3 ++ f4 - return fresh where + let rs = Set.toList $ Set.fromList $ concat $ map getRequires os + collectAllM_ $ [ + checkHash, + checkInput time (p moduleFilename), + checkMissing ps ps2, + checkMissing xs xs2, + checkMissing ts ts2 + ] ++ + (map (checkDep time) $ is ++ is2) ++ + (map (checkInput time . (p2 )) $ ps ++ xs) ++ + (map (checkInput time . getCachedPath p2 "") $ hxx ++ cxx) ++ + (map checkOutput bs) ++ + (map checkObject os) ++ + (map checkRequire rs) + where + checkHash = + when (not $ checkModuleVersionHash h m) $ + compileErrorM $ "Module \"" ++ p ++ "\" was compiled with a different compiler setup" checkInput time f = do exists <- doesFileOrDirExist f - if not exists - then do - compileWarningM $ "Required path \"" ++ f ++ "\" is missing" - return True - else do - time2 <- errorFromIO $ getModificationTime f - if time2 > time - then do - compileWarningM $ "Required path \"" ++ f ++ "\" is newer than cached data" - return True - else return False + when (not exists) $ compileErrorM $ "Required path \"" ++ f ++ "\" is missing" + time2 <- errorFromIO $ getModificationTime f + when (time2 > time) $ compileErrorM $ "Required path \"" ++ f ++ "\" is newer than cached data" checkOutput f = do exists <- errorFromIO $ doesFileExist f - if not exists - then do - compileWarningM $ "Output file \"" ++ f ++ "\" is missing" - return True - else return False - checkMissing s0 s1 = not $ null $ (Set.fromList s1) `Set.difference` (Set.fromList s0) + when (not exists) $ compileErrorM $ "Output file \"" ++ f ++ "\" is missing" + checkDep time dep = do + cm <- loadMetadata ca dep + mapErrorsM_ (checkInput time . (cmPath cm )) $ cmPublicFiles cm + checkObject (CategoryObjectFile _ _ fs) = mapErrorsM_ checkOutput fs + checkObject (OtherObjectFile f) = checkOutput f + getRequires (CategoryObjectFile _ rs _) = rs + getRequires _ = [] + checkRequire (CategoryIdentifier d c ns) = do + cm <- loadMetadata ca d + when (cmPath cm /= p2 && ns /= cmPublicNamespace cm) $ + compileErrorM $ "Required category " ++ show c ++ " is newer than cached data" + checkRequire (UnresolvedCategory c) = + compileErrorM $ "Required category " ++ show c ++ " is unresolved" + checkMissing s0 s1 = do + let missing = Set.toList $ Set.fromList s1 `Set.difference` Set.fromList s0 + mapErrorsM_ (\f -> compileErrorM $ "Required path \"" ++ f ++ "\" has not been compiled") missing doesFileOrDirExist f2 = do existF <- errorFromIO $ doesFileExist f2 if existF @@ -346,11 +360,11 @@ categoryMap = Map.fromList $ directCategories ++ depCategories directCategories = map (keyByCategory . cxxToId) $ map snd categories depCategories = map keyByCategory $ concat (map categoriesToIds deps) - getCats dep - -- Allow ModuleOnly when the path is the same. Only needed for tests. - | cmPath dep == p = cmPrivateCategories dep ++ cmPublicCategories dep - | otherwise = cmPublicCategories dep - categoriesToIds dep = map (\c -> CategoryIdentifier (cmPath dep) c (cmNamespace dep)) $ getCats dep + getCats dep = zip (cmPublicCategories dep) (repeat $ cmPublicNamespace dep) ++ + -- Allow ModuleOnly when the path is the same. Only needed for tests. + -- TODO: The path comparison here is sloppy. + (if cmPath dep == p then zip (cmPrivateCategories dep) (repeat $ cmPrivateNamespace dep) else []) + categoriesToIds dep = map (uncurry $ CategoryIdentifier $ cmPath dep) $ getCats dep cxxToId (CxxOutput (Just c) _ ns _ _ _) = CategoryIdentifier d c ns cxxToId _ = undefined resolveCategory (fs,ca@(CxxOutput _ _ _ ns2 ds _)) = @@ -375,30 +389,38 @@ Nothing -> resolveDep cm ns d resolveDep _ _ d = [UnresolvedCategory d] -loadModuleGlobals :: PathIOHandler r => r -> FilePath -> Namespace -> [FilePath] -> - [CompileMetadata] -> [CompileMetadata] -> CompileInfoIO ([WithVisibility (AnyCategory SourcePos)]) -loadModuleGlobals r p ns2 fs deps1 deps2 = do +loadModuleGlobals :: PathIOHandler r => r -> FilePath -> (Namespace,Namespace) -> [FilePath] -> + Maybe CompileMetadata -> [CompileMetadata] -> [CompileMetadata] -> + CompileInfoIO ([WithVisibility (AnyCategory SourcePos)]) +loadModuleGlobals r p (ns0,ns1) fs m deps1 deps2 = do let public = Set.fromList $ map cmPath deps1 let deps2' = filter (\cm -> not $ cmPath cm `Set.member` public) deps2 - cs0 <- fmap concat $ mapErrorsM (processDeps [FromDependency]) deps1 - cs1 <- fmap concat $ mapErrorsM (processDeps [FromDependency,ModuleOnly]) deps2' - cs2 <- loadAllPublic ns2 fs - return (cs0++cs1++cs2) where - processDeps ss dep = do + cs0 <- fmap concat $ mapErrorsM (processDeps False [FromDependency]) deps1 + cs1 <- fmap concat $ mapErrorsM (processDeps False [FromDependency,ModuleOnly]) deps2' + cs2 <- loadAllPublic (ns0,ns1) fs + cs3 <- case m of + Just m2 -> processDeps True [FromDependency] m2 + _ -> return [] + return (cs0++cs1++cs2++cs3) where + processDeps same ss dep = do let fs2 = getSourceFilesForDeps [dep] - cs <- loadAllPublic (cmNamespace dep) fs2 - let cs' = if cmPath dep /= p + cs <- loadAllPublic (cmPublicNamespace dep,cmPrivateNamespace dep) fs2 + let cs' = if not same -- Allow ModuleOnly if the dep is the same module being -- compiled. (Tests load the module being tested as a dep.) then filter (not . hasCodeVisibility ModuleOnly) cs else cs return $ map (updateCodeVisibility (Set.union (Set.fromList ss))) cs' - loadAllPublic ns fs2 = do + loadAllPublic (ns2,ns3) fs2 = do fs2' <- zipWithContents r p fs2 fmap concat $ mapErrorsM loadPublic fs2' where loadPublic p3 = do (pragmas,cs) <- parsePublicSource p3 - let tags = (if any isTestsOnly pragmas then [TestsOnly] else []) ++ + let tags = Set.fromList $ + (if any isTestsOnly pragmas then [TestsOnly] else []) ++ (if any isModuleOnly pragmas then [ModuleOnly] else []) - return $ map (WithVisibility (Set.fromList tags) . setCategoryNamespace ns) cs + let cs' = if any isModuleOnly pragmas + then map (setCategoryNamespace ns3) cs + else map (setCategoryNamespace ns2) cs + return $ map (WithVisibility tags) cs' diff --git a/src/Parser/Common.hs b/src/Parser/Common.hs --- a/src/Parser/Common.hs +++ b/src/Parser/Common.hs @@ -137,10 +137,20 @@ valueSymbolGet = sepAfter (string_ ".") categorySymbolGet :: Parser () -categorySymbolGet = sepAfter (string_ "$$") +categorySymbolGet = labeled ":" $ useNewOperators <|> sepAfter (string_ ":") typeSymbolGet :: Parser () -typeSymbolGet = sepAfter (string_ "$" >> notFollowedBy (string_ "$")) +typeSymbolGet = labeled "." $ useNewOperators <|> sepAfter (string_ ".") + +-- TODO: Remove this after a reasonable amount of time. +useNewOperators :: Parser () +useNewOperators = newCategory <|> newType where + newCategory = do + try $ string_ "$$" + fail "use \":\" instead of \"$$\" to call @category functions" + newType = do + try $ string_ "$" + fail "use \".\" instead of \"$\" to call @type functions" assignOperator :: Parser () assignOperator = operator "<-" >> return () diff --git a/src/Parser/Procedure.hs b/src/Parser/Procedure.hs --- a/src/Parser/Procedure.hs +++ b/src/Parser/Procedure.hs @@ -35,7 +35,6 @@ import Types.Pragma import Types.Procedure import Types.TypeCategory -import Types.TypeInstance instance ParseFromSource (ExecutableProcedure SourcePos) where @@ -168,7 +167,7 @@ strayFuncCall <|> return () return $ ExistingVariable n strayFuncCall = do - valueSymbolGet <|> try typeSymbolGet <|> categorySymbolGet + valueSymbolGet <|> typeSymbolGet <|> categorySymbolGet fail "function returns must be explicitly handled" instance ParseFromSource (VoidExpression SourcePos) where @@ -304,7 +303,7 @@ e <- notInfix asInfix [e] [] <|> return e where - notInfix = literal <|> unary <|> expression <|> initalize + notInfix = literal <|> unary <|> initalize <|> expression asInfix es os = do c <- getPosition o <- infixOperator <|> functionOperator @@ -331,13 +330,15 @@ return $ UnaryExpression [c] o e expression = labeled "expression" $ do c <- getPosition - s <- try sourceParser + s <- sourceParser vs <- many sourceParser return $ Expression [c] s vs initalize = do c <- getPosition - t <- try sourceParser :: Parser TypeInstance - sepAfter (string_ "{") + t <- try $ do -- Avoids consuming the type name if { isn't present. + t2 <- sourceParser + sepAfter (labeled "@value initializer" $ string_ "{") + return t2 withParams c t <|> withoutParams c t withParams c t = do try kwTypes @@ -354,22 +355,24 @@ instance ParseFromSource (FunctionQualifier SourcePos) where -- TODO: This is probably better done iteratively. - sourceParser = try valueFunc <|> try categoryFunc <|> try typeFunc where + sourceParser = valueFunc <|> categoryFunc <|> typeFunc where + valueFunc = do + c <- getPosition + q <- try sourceParser + valueSymbolGet + return $ ValueFunction [c] q categoryFunc = do c <- getPosition - q <- sourceParser - categorySymbolGet + q <- try $ do -- Avoids consuming the type name if : isn't present. + q2 <- sourceParser + categorySymbolGet + return q2 return $ CategoryFunction [c] q typeFunc = do c <- getPosition - q <- sourceParser + q <- try 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 @@ -429,7 +432,7 @@ builtinValue <|> sourceContext <|> exprLookup <|> - try typeOrCategoryCall <|> + categoryCall <|> typeCall where parens = do c <- getPosition @@ -475,24 +478,19 @@ asUnqualifiedCall c n = do f <- parseFunctionCall c (FunctionName (vnName n)) return $ UnqualifiedCall [c] f - typeOrCategoryCall = do + categoryCall = 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 + t <- try $ do -- Avoids consuming the type name if : isn't present. + t2 <- sourceParser + categorySymbolGet + return t2 n <- sourceParser f <- parseFunctionCall c n return $ CategoryCall [c] t f typeCall = do c <- getPosition t <- try sourceParser - try typeSymbolGet + typeSymbolGet n <- sourceParser f <- parseFunctionCall c n return $ TypeCall [c] t f diff --git a/src/Parser/TypeInstance.hs b/src/Parser/TypeInstance.hs --- a/src/Parser/TypeInstance.hs +++ b/src/Parser/TypeInstance.hs @@ -25,6 +25,7 @@ import Control.Applicative ((<|>)) import Text.Parsec hiding ((<|>)) +import Base.Mergeable (mergeAll,mergeAny) import Parser.Common import Types.GeneralType import Types.Positional @@ -35,24 +36,25 @@ sourceParser = try allT <|> try anyT <|> intersectOrUnion <|> single where allT = labeled "all" $ do kwAll - return $ TypeMerge MergeUnion [] + return minBound anyT = 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 + return maxBound + intersectOrUnion = labeled "union or intersection" $ do + sepAfter $ string_ "[" + t1 <- labeled "type" $ sepAfter sourceParser + t <- intersect t1 <|> union t1 + sepAfter $ string_ "]" + return t + intersect t1 = do + ts <- many1 (sepAfter (string_ "&") >> labeled "type" sourceParser) + return $ mergeAll (t1:ts) + union t1 = do + ts <- many1 (sepAfter (string_ "|") >> labeled "type" sourceParser) + return $ mergeAny (t1:ts) single = do t <- sourceParser - return $ SingleType t + return $ singleType t instance ParseFromSource ValueType where sourceParser = do @@ -126,11 +128,11 @@ requires = labeled "requires filter" $ do try kwRequires t <- sourceParser - return $ TypeFilter FilterRequires t + return $ TypeFilter FilterRequires $ singleType t allows = labeled "allows filter" $ do try kwAllows t <- sourceParser - return $ TypeFilter FilterAllows t + return $ TypeFilter FilterAllows $ singleType t defines = labeled "defines filter" $ do try kwDefines t <- sourceParser diff --git a/src/Test/Common.hs b/src/Test/Common.hs --- a/src/Test/Common.hs +++ b/src/Test/Common.hs @@ -51,7 +51,6 @@ import qualified Data.Set as Set import Base.CompileError -import Base.Mergeable import Base.CompileInfo import Parser.Common import Parser.TypeInstance () @@ -119,7 +118,7 @@ check $ validateGeneralInstance r pa2 t where prefix = x ++ " " ++ showParams pa - check x2 = x2 r -> [(String,[String])] -> String -> CompileInfo () checkTypeFail r pa x = do @@ -138,7 +137,7 @@ check $ validateDefinesInstance r pa2 t where prefix = x ++ " " ++ showParams pa - check x2 = x2 r -> [(String,[String])] -> String -> CompileInfo () checkDefinesFail r pa x = do @@ -159,7 +158,7 @@ containsNoDuplicates :: (Ord a, Show a) => [a] -> CompileInfo () containsNoDuplicates expected = - (mergeAllM $ map checkSingle $ group $ sort expected) [a] -> [a] -> CompileInfo () containsAtLeast actual expected = - (mergeAllM $ map (checkInActual $ Set.fromList actual) expected) [a] -> [a] -> CompileInfo () containsAtMost actual expected = - (mergeAllM $ map (checkInExpected $ Set.fromList expected) actual) > return () >> compileWarningM "warning2"), - checkErrorAndWarnings ["warning1"] "error\n" + checkErrorAndWarnings "warning1\n" "error\n" (compileWarningM "warning1" >> compileErrorM "error" >> compileWarningM "warning2" :: CompileInfoIO ()), checkSuccess ['a','b'] (sequence [return 'a',return 'b']), checkSuccess [] (sequence [] :: CompileInfoIO [Char]), checkError "error1\n" (sequence [compileErrorM "error1",return 'b',compileErrorM "error2"]), - checkSuccess 'a' (return 'a' `reviseErrorM` "message"), - checkError "message\n error\n" (compileErrorM "error" `reviseErrorM` "message" :: CompileInfoIO ()), + checkSuccess 'a' (return 'a' `withContextM` "message"), + checkError "message\n error\n" (compileErrorM "error" `withContextM` "message" :: CompileInfoIO ()), + checkSuccessAndWarnings "message\n warning\n" () + (compileWarningM "warning" `withContextM` "message" :: CompileInfoIO ()), + checkErrorAndWarnings "message\n warning\n" "message\n error\n" + ((compileWarningM "warning" >> compileErrorM "error") `withContextM` "message" :: CompileInfoIO ()), + checkSuccessAndWarnings "" () (return () `withContextM` "message"), + checkErrorAndWarnings "" "message\n" (compileErrorM "" `withContextM` "message" :: CompileInfoIO ()), + checkSuccess 'a' (return 'a' `summarizeErrorsM` "message"), + checkError "message\n error\n" (compileErrorM "error" `summarizeErrorsM` "message" :: CompileInfoIO ()), + checkSuccessAndWarnings "warning\n" () + (compileWarningM "warning" `summarizeErrorsM` "message" :: CompileInfoIO ()), + checkErrorAndWarnings "warning\n" "message\n error\n" + ((compileWarningM "warning" >> compileErrorM "error") `summarizeErrorsM` "message" :: CompileInfoIO ()), + checkSuccessAndWarnings "" () (return () `summarizeErrorsM` "message"), + checkErrorAndWarnings "" "message\n" (compileErrorM "" `summarizeErrorsM` "message" :: CompileInfoIO ()), + + checkSuccessAndWarnings "error\n" () + (asCompileWarnings $ compileErrorM "error" :: CompileInfoIO ()), + checkErrorAndWarnings "" "warning\n" + (asCompileError $ compileWarningM "warning" :: CompileInfoIO ()), + checkSuccess 'a' (compileBackgroundM "background" >> return 'a'), checkError "error\n background\n" (compileBackgroundM "background" >> compileErrorM "error" :: CompileInfoIO ()), checkError "error\n background\n" - (collectAllOrErrorM [compileBackgroundM "background"] >> compileErrorM "error" :: CompileInfoIO [()]), - checkError "error\n background\n" - (collectOneOrErrorM [compileBackgroundM "background"] >> compileErrorM "error" :: CompileInfoIO ()), - checkError "error\n background\n" - (mergeAllM [compileBackgroundM "background"] >> compileErrorM "error" :: CompileInfoIO ()), + (collectAllM [compileBackgroundM "background"] >> compileErrorM "error" :: CompileInfoIO [()]), checkError "error\n background\n" - (mergeAnyM [compileBackgroundM "background"] >> compileErrorM "error" :: CompileInfoIO ()), + (collectFirstM [compileBackgroundM "background"] >> compileErrorM "error" :: CompileInfoIO ()), checkSuccess 'a' ((resetBackgroundM $ compileBackgroundM "background") >> return 'a'), checkError "error\n" @@ -91,18 +103,18 @@ then return $ return () else return $ compileErrorM $ "Expected error \"" ++ e ++ "\" but got error \"" ++ show (getCompileError y') ++ "\"" -checkSuccessAndWarnings :: (Eq a, Show a) => [String] -> a -> CompileInfoIO a -> IO (CompileInfo ()) +checkSuccessAndWarnings :: (Eq a, Show a) => String -> a -> CompileInfoIO a -> IO (CompileInfo ()) checkSuccessAndWarnings w x y = do y' <- toCompileInfo y outcome <- checkSuccess x y - if getCompileWarnings y' == w + if show (getCompileWarnings y') == w then return $ outcome >> return () - else return $ compileErrorM $ "Expected warnings " ++ show w ++ " but got warnings " ++ show (getCompileWarnings y') + else return $ compileErrorM $ "Expected warnings " ++ show w ++ " but got warnings \"" ++ show (getCompileWarnings y') ++ "\"" -checkErrorAndWarnings :: (Eq a, Show a) => [String] -> String -> CompileInfoIO a -> IO (CompileInfo ()) +checkErrorAndWarnings :: (Eq a, Show a) => String -> String -> CompileInfoIO a -> IO (CompileInfo ()) checkErrorAndWarnings w e y = do y' <- toCompileInfo y outcome <- checkError e y - if getCompileWarnings y' == w + if show (getCompileWarnings y') == w then return $ outcome >> return () - else return $ compileErrorM $ "Expected warnings " ++ show w ++ " but got warnings " ++ show (getCompileWarnings y') + else return $ compileErrorM $ "Expected warnings " ++ show w ++ " but got warnings \"" ++ show (getCompileWarnings y') ++ "\"" diff --git a/src/Test/MergeTree.hs b/src/Test/MergeTree.hs --- a/src/Test/MergeTree.hs +++ b/src/Test/MergeTree.hs @@ -21,6 +21,7 @@ module Test.MergeTree (tests) where import Control.Monad (when) +import Data.Char (toUpper) import Base.CompileError import Base.CompileInfo @@ -35,8 +36,8 @@ checkMatch (mergeAll $ fmap mergeLeaf [2,4,6]) (fmap (*2)) (mergeAll $ map mergeLeaf [1..3] :: MergeTree Int), - checkMatch (mergeLeaf 1) id (mergeAny [mergeLeaf 1,mergeAny []] :: MergeTree Int), - checkMatch (mergeLeaf 1) id (mergeAll [mergeLeaf 1,mergeAll []] :: MergeTree Int), + checkMatch (mergeLeaf 1) id (mergeAny [mergeLeaf 1,minBound] :: MergeTree Int), + checkMatch (mergeLeaf 1) id (mergeAll [mergeLeaf 1,maxBound] :: MergeTree Int), checkMatch2 (mergeAny [mergeLeaf 1,mergeLeaf 2,mergeAll [mergeLeaf 3,mergeLeaf 4]]) (mergeAny [mergeLeaf 1,mergeLeaf 2,mergeLeaf 3,mergeLeaf 4]) @@ -45,45 +46,121 @@ (mergeAll [mergeLeaf 1,mergeLeaf 2,mergeLeaf 3,mergeLeaf 4]) (mergeAll [mergeAll [mergeLeaf 1],mergeLeaf 2,mergeAny [mergeLeaf 3,mergeLeaf 4]] :: MergeTree Int), - checkMatch ([1,2]) (foldr (:) []) - (mergeAny [mergeLeaf 1,mergeAll [mergeLeaf 2]] :: MergeTree Int), - checkMatch ([1,2]) (foldr (:) []) - (mergeAll [mergeLeaf 1,mergeAny [mergeLeaf 2]] :: MergeTree Int), + -- a*(b&c)*(d|e) = (a*b&a*c)*(d|e) = (a*b*(d|e)&a*c*(d|e)) = (a*b*d|a*b*e)&(a*c*d|a*c*e) + checkMatch (mergeAll [mergeAny [mergeLeaf "abd",mergeLeaf "abe"],mergeAny [mergeLeaf "acd",mergeLeaf "ace"]]) sequence + [mergeLeaf 'a',mergeAll [mergeLeaf 'b',mergeLeaf 'c'],mergeAny [mergeLeaf 'd',mergeLeaf 'e']], - checkSuccess (mergeAny $ fmap mergeLeaf [1,2,3]) (sequence . fmap return) - (mergeAny $ map mergeLeaf [1..3] :: MergeTree Int), - checkSuccess (mergeAll $ fmap mergeLeaf [1,2,3]) (sequence . fmap return) - (mergeAll $ map mergeLeaf [1..3] :: MergeTree Int), + checkMatch (mergeAll [mergeAll [mergeLeaf 'a',mergeLeaf 'A'], + mergeAny [mergeAll [mergeLeaf 'b',mergeLeaf 'B'], + mergeAll [mergeLeaf 'c',mergeLeaf 'C']]]) + (\x -> do + x' <- x + mergeAll [return x',return (toUpper x')]) + (mergeAll [mergeLeaf 'a',mergeAny [mergeLeaf 'b',mergeLeaf 'c']]), - checkError "1 is odd\n" (sequence . fmap oddError) - (mergeAny $ map mergeLeaf [1..3] :: MergeTree Int), - checkError "1 is odd\n" (sequence . fmap oddError) - (mergeAll $ map mergeLeaf [1..3] :: MergeTree Int), - checkSuccess (mergeAny $ map mergeLeaf [1..3]) (sequence . fmap return) - (mergeAny $ map mergeLeaf [1..3] :: MergeTree Int), - checkSuccess (mergeAll $ map mergeLeaf [1..3]) (sequence . fmap return) - (mergeAll $ map mergeLeaf [1..3] :: MergeTree Int), + checkMatch [mergeAll [mergeAny [mergeLeaf 'a',mergeLeaf 'b'], + mergeAny [mergeLeaf 'c', + mergeAll [mergeLeaf 'd',mergeLeaf 'e']], + mergeLeaf 'f']] + sequence -- MergeTree [Char] -> [MergeTree Char] + (mergeAll [mergeAny [mergeLeaf "a",mergeLeaf "b"], + mergeAny [mergeLeaf "c", + mergeAll [mergeLeaf "d",mergeLeaf "e"]], + mergeLeaf "f"]), - checkSuccess (mergeAny $ map mergeLeaf [2,4]) (pruneMergeTree . fmap oddError) - (mergeAny $ map mergeLeaf [1..4] :: MergeTree Int), - checkError "1 is odd\n3 is odd\n" (pruneMergeTree . fmap oddError) - (mergeAll $ map mergeLeaf [1..4] :: MergeTree Int), - checkSuccess (mergeAny $ map mergeLeaf [1..4]) (pruneMergeTree . fmap return) - (mergeAny $ map mergeLeaf [1..4] :: MergeTree Int), - checkSuccess (mergeAll $ map mergeLeaf [1..4]) (pruneMergeTree . fmap return) - (mergeAll $ map mergeLeaf [1..4] :: MergeTree Int), + checkMatch (mergeAll [mergeAny [mergeLeaf "a",mergeLeaf "b"], + mergeAny [mergeLeaf "c", + mergeAll [mergeLeaf "d",mergeLeaf "e"]], + mergeLeaf "f"]) + sequence -- [MergeTree Char] -> MergeTree [Char] + [mergeAll [mergeAny [mergeLeaf 'a',mergeLeaf 'b'], + mergeAny [mergeLeaf 'c', + mergeAll [mergeLeaf 'd',mergeLeaf 'e']], + mergeLeaf 'f']], - checkSuccess [2,4] - (reduceMergeTree return (\xs -> compileErrorM $ "mergeAll " ++ show xs) oddError2) - (mergeAny $ map mergeLeaf [1..4] :: MergeTree Int), - checkError "1 is odd\n3 is odd\n" - (reduceMergeTree (\xs -> compileErrorM $ "mergeAny " ++ show xs) return oddError2) - (mergeAll $ map mergeLeaf [1..4] :: MergeTree Int) + checkMatch (mergeAll [mergeAny [mergeLeaf 'A',mergeLeaf 'B'], + mergeAny [mergeLeaf 'C', + mergeAll [mergeLeaf 'D',mergeLeaf 'E']], + mergeLeaf 'F']) + (toUpper <$>) + (mergeAll [mergeAny [mergeLeaf 'a',mergeLeaf 'b'], + mergeAny [mergeLeaf 'c', + mergeAll [mergeLeaf 'd',mergeLeaf 'e']], + mergeLeaf 'f']), + + checkMatch (mergeAll [mergeAny [mergeLeaf 'A',mergeLeaf 'B'], + mergeAny [mergeLeaf 'C', + mergeAll [mergeLeaf 'D',mergeLeaf 'E']], + mergeLeaf 'F']) + ((mergeAll [mergeAny [mergeLeaf ($'a'),mergeLeaf ($'b')], + mergeAny [mergeLeaf ($'c'), + mergeAll [mergeLeaf ($'d'),mergeLeaf ($'e')]], + mergeLeaf ($'f')]) <*>) + (mergeLeaf toUpper), + + checkMatch True + (uncurry $ pairMergeTree mergeAny mergeAll (==)) + (minBound :: MergeTree (),minBound :: MergeTree ()), + checkMatch True + (uncurry $ pairMergeTree mergeAny mergeAll (==)) + (maxBound :: MergeTree (),maxBound :: MergeTree ()), + checkMatch True + (uncurry $ pairMergeTree mergeAny mergeAll (==)) + (minBound :: MergeTree (),maxBound :: MergeTree ()), + checkMatch False + (uncurry $ pairMergeTree mergeAny mergeAll (==)) + (maxBound :: MergeTree (),minBound :: MergeTree ()), + + checkMatch True + (uncurry $ pairMergeTree mergeAny mergeAll (==)) + (mergeAll [mergeLeaf 'a',mergeLeaf 'b'], + mergeAny [mergeLeaf 'a',mergeLeaf 'b',mergeLeaf 'c']), + checkMatch True + (uncurry $ pairMergeTree mergeAny mergeAll (==)) + (mergeAll [mergeLeaf 'a',mergeLeaf 'b',mergeLeaf 'c'], + mergeAny [mergeLeaf 'a',mergeLeaf 'b']), + checkMatch False + (uncurry $ pairMergeTree mergeAny mergeAll (==)) + (mergeAny [mergeLeaf 'a',mergeLeaf 'b'], + mergeAll [mergeLeaf 'a',mergeLeaf 'b',mergeLeaf 'c']), + checkMatch False + (uncurry $ pairMergeTree mergeAny mergeAll (==)) + (mergeAny [mergeLeaf 'a',mergeLeaf 'b',mergeLeaf 'c'], + mergeAll [mergeLeaf 'a',mergeLeaf 'b']), + checkMatch True + (uncurry $ pairMergeTree mergeAny mergeAll (==)) + (mergeAny [mergeLeaf 'a',mergeLeaf 'b'], + mergeAny [mergeLeaf 'a',mergeLeaf 'b']), + checkMatch True + (uncurry $ pairMergeTree mergeAny mergeAll (==)) + (mergeAll [mergeLeaf 'a',mergeLeaf 'b'], + mergeAll [mergeLeaf 'a',mergeLeaf 'b']), + + checkMatch True + (uncurry $ pairMergeTree mergeAny mergeAll (==)) + (mergeAll [mergeLeaf 'a',mergeLeaf 'b'], + mergeAny [mergeAll [mergeLeaf 'a',mergeLeaf 'b'],mergeLeaf 'c']), + checkMatch True + (uncurry $ pairMergeTree mergeAny mergeAll (==)) + (mergeAll [mergeAny [mergeLeaf 'a',mergeLeaf 'b'],mergeLeaf 'c'], + mergeAny [mergeLeaf 'a',mergeLeaf 'b']), + checkMatch True + (uncurry $ pairMergeTree mergeAny mergeAll (==)) + (mergeAny [mergeAll [mergeLeaf 'a',mergeLeaf 'b'],mergeLeaf 'c'], + mergeAny [mergeAll [mergeLeaf 'a',mergeLeaf 'b'],mergeLeaf 'c']), + checkMatch True + (uncurry $ pairMergeTree mergeAny mergeAll (==)) + (mergeAll [mergeAny [mergeLeaf 'a',mergeLeaf 'b'],mergeLeaf 'c'], + mergeAll [mergeAny [mergeLeaf 'a',mergeLeaf 'b'],mergeLeaf 'c']), + checkMatch False + (uncurry $ pairMergeTree mergeAny mergeAll (==)) + (mergeAny [mergeLeaf 'a',mergeLeaf 'b'], + mergeAll [mergeLeaf 'a',mergeLeaf 'b']) ] oddError :: Int -> CompileInfo Int oddError x = do - when (x `mod` 2 == 1) $ compileErrorM $ show x ++ " is odd" + when (odd x) $ compileErrorM $ show x ++ " is odd" return x oddError2 :: Int -> CompileInfo [Int] diff --git a/src/Test/ParseMetadata.hs b/src/Test/ParseMetadata.hs --- a/src/Test/ParseMetadata.hs +++ b/src/Test/ParseMetadata.hs @@ -39,7 +39,8 @@ checkWriteThenRead $ CompileMetadata { cmVersionHash = VersionHash "0123456789ABCDEFabcdef", cmPath = "/home/project/special", - cmNamespace = StaticNamespace "public_ABCDEF", + cmPublicNamespace = StaticNamespace "public_ABCDEF", + cmPrivateNamespace = StaticNamespace "private_ABCDEF", cmPublicDeps = [ "/home/project/public-dep1", "/home/project/public-dep2" @@ -56,10 +57,14 @@ CategoryName "PrivateCategory", CategoryName "PrivateOtherCategory" ], - cmSubdirs = [ + cmPublicSubdirs = [ "/home/project/special/subdir1", "/home/project/special/subdir2" ], + cmPrivateSubdirs = [ + "/home/project/special/subdir1", + "/home/project/special/subdir2" + ], cmPublicFiles = [ "/home/project/special/category1.0rp", "/home/project/special/category2.0rp" @@ -116,12 +121,14 @@ checkWriteFail "bad hash" $ CompileMetadata { cmVersionHash = VersionHash "bad hash", cmPath = "/home/project/special", - cmNamespace = NoNamespace, + cmPublicNamespace = NoNamespace, + cmPrivateNamespace = NoNamespace, cmPublicDeps = [], cmPrivateDeps = [], cmPublicCategories = [], cmPrivateCategories = [], - cmSubdirs = [], + cmPublicSubdirs = [], + cmPrivateSubdirs = [], cmPublicFiles = [], cmPrivateFiles = [], cmTestFiles = [], @@ -135,12 +142,14 @@ checkWriteFail "bad namespace" $ CompileMetadata { cmVersionHash = VersionHash "0123456789ABCDEFabcdef", cmPath = "/home/project/special", - cmNamespace = StaticNamespace "bad namespace", + cmPublicNamespace = StaticNamespace "bad namespace", + cmPrivateNamespace = NoNamespace, cmPublicDeps = [], cmPrivateDeps = [], cmPublicCategories = [], cmPrivateCategories = [], - cmSubdirs = [], + cmPublicSubdirs = [], + cmPrivateSubdirs = [], cmPublicFiles = [], cmPrivateFiles = [], cmTestFiles = [], @@ -151,17 +160,40 @@ cmObjectFiles = [] }, + checkWriteFail "bad namespace" $ CompileMetadata { + cmVersionHash = VersionHash "0123456789ABCDEFabcdef", + cmPath = "/home/project/special", + cmPublicNamespace = NoNamespace, + cmPrivateNamespace = StaticNamespace "bad namespace", + cmPublicDeps = [], + cmPrivateDeps = [], + cmPublicCategories = [], + cmPrivateCategories = [], + cmPublicSubdirs = [], + cmPrivateSubdirs = [], + cmPublicFiles = [], + cmPrivateFiles = [], + cmTestFiles = [], + cmHxxFiles = [], + cmCxxFiles = [], + cmBinaries = [], + cmLinkFlags = [], + cmObjectFiles = [] + }, + checkWriteFail "bad category" $ CompileMetadata { cmVersionHash = VersionHash "0123456789ABCDEFabcdef", cmPath = "/home/project/special", - cmNamespace = NoNamespace, + cmPublicNamespace = NoNamespace, + cmPrivateNamespace = NoNamespace, cmPublicDeps = [], cmPrivateDeps = [], cmPublicCategories = [ CategoryName "bad category" ], cmPrivateCategories = [], - cmSubdirs = [], + cmPublicSubdirs = [], + cmPrivateSubdirs = [], cmPublicFiles = [], cmPrivateFiles = [], cmTestFiles = [], @@ -175,14 +207,16 @@ checkWriteFail "bad category" $ CompileMetadata { cmVersionHash = VersionHash "0123456789ABCDEFabcdef", cmPath = "/home/project/special", - cmNamespace = NoNamespace, + cmPublicNamespace = NoNamespace, + cmPrivateNamespace = NoNamespace, cmPublicDeps = [], cmPrivateDeps = [], cmPublicCategories = [], cmPrivateCategories = [ CategoryName "bad category" ], - cmSubdirs = [], + cmPublicSubdirs = [], + cmPrivateSubdirs = [], cmPublicFiles = [], cmPrivateFiles = [], cmTestFiles = [], @@ -194,25 +228,25 @@ }, checkWriteThenRead $ ModuleConfig { - rmRoot = "/home/projects", - rmPath = "special", - rmExprMap = [], - rmPublicDeps = [ + mcRoot = "/home/projects", + mcPath = "special", + mcExprMap = [], + mcPublicDeps = [ "/home/project/public-dep1", "/home/project/public-dep2" ], - rmPrivateDeps = [ + mcPrivateDeps = [ "/home/project/private-dep1", "/home/project/private-dep2" ], - rmExtraFiles = [ + mcExtraFiles = [ CategorySource { csSource = "extra1.cpp", csCategories = [ CategoryName "Category1", CategoryName "Category2" ], - csDepCategories = [ + csRequires = [ CategoryName "DepCategory1", CategoryName "DepCategory2" ] @@ -221,11 +255,11 @@ osSource = "extra2.cpp" } ], - rmExtraPaths = [ + mcExtraPaths = [ "extra1", "extra2" ], - rmMode = CompileIncremental { + mcMode = CompileIncremental { ciLinkFlags = [ "-lm", "-ldl" @@ -234,14 +268,14 @@ }, checkWriteFail "empty.+map" $ ModuleConfig { - rmRoot = "/home/projects", - rmPath = "special", - rmExprMap = [("MACRO",Literal (StringLiteral [] "something"))], - rmPublicDeps = [], - rmPrivateDeps = [], - rmExtraFiles = [], - rmExtraPaths = [], - rmMode = CompileIncremental { + mcRoot = "/home/projects", + mcPath = "special", + mcExprMap = [("MACRO",Literal (StringLiteral [] "something"))], + mcPublicDeps = [], + mcPrivateDeps = [], + mcExtraFiles = [], + mcExtraPaths = [], + mcMode = CompileIncremental { ciLinkFlags = [] } }, @@ -251,13 +285,13 @@ csCategories = [ CategoryName "bad category" ], - csDepCategories = [] + csRequires = [] }, checkWriteFail "bad category" $ CategorySource { csSource = "extra1.cpp", csCategories = [], - csDepCategories = [ + csRequires = [ CategoryName "bad category" ] }, @@ -318,7 +352,7 @@ checkWriteFail "compile mode" $ CreateTemplates, checkParsesAs ("testfiles" "module-config.txt") - (\m -> case rmExprMap m of + (\m -> case mcExprMap m of [("MY_MACRO", Expression _ (BuiltinCall _ (FunctionCall _ BuiltinRequire (Positional []) @@ -335,7 +369,7 @@ checkWriteThenRead :: (Eq a, Show a, ConfigFormat a) => a -> IO (CompileInfo ()) checkWriteThenRead m = return $ do text <- fmap spamComments $ autoWriteConfig m - m' <- autoReadConfig "(string)" text >>\n\n" ++ text ++ "\n<<< Serialized\n\n") + m' <- autoReadConfig "(string)" text >>\n\n" ++ text ++ "\n<<< Serialized\n\n") when (m' /= m) $ compileErrorM $ "Failed to match after write/read\n" ++ "Before:\n" ++ show m ++ "\n" ++ @@ -363,7 +397,7 @@ return $ check parsed contents where check x contents = do - x' <- x $func()", - checkShortParseSuccess "return var, var.T<#x>$func()", - checkShortParseFail "return var var.T<#x>$func()", + 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()", + checkShortParseSuccess "\\ T:func()", + checkShortParseFail "\\ T$$func()", checkShortParseFail "\\ T$ $func()", + checkShortParseFail "\\ T<#x>:func()", + checkShortParseFail "\\ var.T:func()", checkShortParseSuccess "break", checkShortParseFail "break var", @@ -61,18 +62,17 @@ 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()", + 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 "\\ var.T<#x>", checkShortParseFail "\\ T<#x> var", - checkShortParseSuccess "\\ T<#x>{ val, var.T<#x>$func() }", - checkShortParseFail "\\ T<#x>{ val var.T<#x>$func() }", + checkShortParseSuccess "\\ T<#x>{ val, var.T<#x>.func() }", + checkShortParseFail "\\ T<#x>{ val var.T<#x>.func() }", checkShortParseFail "\\ T<#x>{}.call()", + checkShortParseFail "\\ T<#x>$call()", checkShortParseSuccess "\\ (T<#x>{}).call()", checkShortParseSuccess "x <- var.func()", @@ -116,28 +116,28 @@ 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 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())).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 "\\ 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 "\\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()", @@ -145,7 +145,7 @@ 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\\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}", @@ -248,7 +248,7 @@ (Expression _ (NamedVariable (OutputValue _ (VariableName "z"))) []))) -> True _ -> False), - checkParsesAs "1 `Int$lessThan` 2" + checkParsesAs "1 `Int.lessThan` 2" (\e -> case e of (InfixExpression _ (Literal (IntegerLiteral _ False 1)) @@ -259,7 +259,7 @@ (Literal (IntegerLiteral _ False 2))) -> True _ -> False), - checkParsesAs "1 `Something$$foo` 2" + checkParsesAs "1 `Something:foo` 2" (\e -> case e of (InfixExpression _ (Literal (IntegerLiteral _ False 1)) @@ -304,7 +304,7 @@ (Literal (IntegerLiteral _ False 2))) -> True _ -> False), - checkParsesAs "`Bits$not` 2" + checkParsesAs "`Bits.not` 2" (\e -> case e of (UnaryExpression _ (FunctionOperator _ ( @@ -314,7 +314,7 @@ (Literal (IntegerLiteral _ False 2))) -> True _ -> False), - checkParsesAs "`Bits$$not` 2" + checkParsesAs "`Bits:not` 2" (\e -> case e of (UnaryExpression _ (FunctionOperator _ diff --git a/src/Test/TypeCategory.hs b/src/Test/TypeCategory.hs --- a/src/Test/TypeCategory.hs +++ b/src/Test/TypeCategory.hs @@ -24,9 +24,9 @@ import System.FilePath import Text.Parsec import qualified Data.Map as Map +import qualified Data.Set as Set import Base.CompileError -import Base.Mergeable import Base.CompileInfo import Parser.TypeCategory () import Test.Common @@ -801,7 +801,7 @@ checkInferenceSuccess tm [("#x",[])] ["#x"] [("Type1","#x")] - [("#x","Type1",Covariant)]), + [("#x","Type1")]), checkOperationSuccess ("testfiles" "inference.0rx") (\ts -> do @@ -809,7 +809,15 @@ checkInferenceSuccess tm [("#x",[])] ["#x"] [("Type2","#x"),("Type1","#x")] - [("#x","Type1",Covariant)]), + [("#x","Type1")]), + checkOperationSuccess + ("testfiles" "inference.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceSuccess tm + [("#x",[])] ["#x"] + [] + []), checkOperationSuccess ("testfiles" "inference.0rx") @@ -818,7 +826,7 @@ checkInferenceSuccess tm [("#x",[])] ["#x"] [("Interface1","#x"),("Interface1","#x")] - [("#x","Interface1",Covariant)]), + [("#x","Interface1")]), checkOperationSuccess ("testfiles" "inference.0rx") @@ -827,7 +835,7 @@ checkInferenceSuccess tm [("#x",[])] ["#x"] [("Interface2","#x"),("Interface2","#x")] - [("#x","Interface2",Covariant)]), + [("#x","Interface2")]), checkOperationSuccess ("testfiles" "inference.0rx") (\ts -> do @@ -836,7 +844,7 @@ [("#x",[])] ["#x"] [("Interface2","Interface2<#x>"), ("Interface2","Interface2<#x>")] - [("#x","Type2",Contravariant)]), + [("#x","Type2")]), checkOperationSuccess ("testfiles" "inference.0rx") @@ -845,14 +853,15 @@ checkInferenceSuccess tm [("#x",[])] ["#x"] [("Interface3","#x"),("Interface3","#x")] - [("#x","Interface3",Covariant)]), + [("#x","Interface3")]), checkOperationSuccess ("testfiles" "inference.0rx") (\ts -> do tm <- includeNewTypes defaultCategories ts - checkInferenceFail tm + checkInferenceSuccess tm [("#x",[])] ["#x"] - [("Interface3","#x"),("Interface3","#x")]), + [("Interface3","#x"),("Interface3","#x")] + [("#x","[Interface3|Interface3]")]), checkOperationSuccess ("testfiles" "inference.0rx") (\ts -> do @@ -861,7 +870,7 @@ [("#x",[])] ["#x"] [("Interface3","Interface3<#x>"), ("Interface3","Interface3<#x>")] - [("#x","Type1",Invariant)]), + [("#x","Type1")]), checkOperationSuccess ("testfiles" "inference.0rx") (\ts -> do @@ -875,12 +884,11 @@ ("testfiles" "inference.0rx") (\ts -> do tm <- includeNewTypes defaultCategories ts - checkInferenceSuccess tm + checkInferenceFail tm [("#x",[])] ["#x"] [("Type1","#x"), ("Interface1","Interface1<#x>"), - ("Interface2","Interface2<#x>")] - [("#x","Type1",Covariant)]), + ("Interface2","Interface2<#x>")]), checkOperationSuccess ("testfiles" "inference.0rx") (\ts -> do @@ -890,26 +898,7 @@ [("Interface3","Interface3<#x>"), ("Interface1","Interface1<#x>"), ("Interface2","Interface2<#x>")] - [("#x","Type2",Invariant)]), - - checkOperationSuccess - ("testfiles" "inference.0rx") - (\ts -> do - tm <- includeNewTypes defaultCategories ts - checkInferenceSuccess tm - [("#x",[]),("#y",["allows #x"])] ["#x"] - [("Interface1","Interface1<#x>"), - ("Type0","#y")] -- The filter for #y influences the guess for #x. - [("#x","Type0",Covariant)]), - checkOperationSuccess - ("testfiles" "inference.0rx") - (\ts -> do - tm <- includeNewTypes defaultCategories ts - checkInferenceSuccess tm - [("#x",[]),("#y",["allows #x"])] ["#x"] - [("Interface1","Interface1<#x>"), - ("Type2","#y")] - [("#x","Type1",Covariant)]), + [("#x","Type2")]), checkOperationSuccess ("testfiles" "inference.0rx") @@ -918,7 +907,7 @@ checkInferenceSuccess tm [("#x",[])] ["#x"] [("Interface1","Interface1<[#x|Interface2<#x>]>")] - [("#x","Type1",Covariant)]), + [("#x","Type1")]), checkOperationSuccess ("testfiles" "inference.0rx") (\ts -> do @@ -926,7 +915,7 @@ checkInferenceSuccess tm [("#x",[])] ["#x"] [("Interface1","Interface1<[#x&Type1]>")] - [("#x","Type2",Covariant)]), + [("#x","Type2")]), checkOperationSuccess ("testfiles" "inference.0rx") (\ts -> do @@ -934,7 +923,7 @@ checkInferenceSuccess tm [("#x",[])] ["#x"] [("Interface2","Interface2<[#x&Interface2<#x>]>")] - [("#x","Type1",Contravariant)]), + [("#x","Type1")]), checkOperationSuccess ("testfiles" "inference.0rx") (\ts -> do @@ -942,7 +931,7 @@ checkInferenceSuccess tm [("#x",[])] ["#x"] [("Interface2","Interface2<[#x|Type1]>")] - [("#x","Type0",Contravariant)]), + [("#x","Type0")]), checkOperationSuccess ("testfiles" "inference.0rx") @@ -950,18 +939,9 @@ tm <- includeNewTypes defaultCategories ts checkInferenceSuccess tm [("#x",[])] ["#x"] - [("Interface3","[Interface1<#x>|Interface3<#x>]")] - -- Guesses are either Type0 or Type1, and Type1 is more specific. - [("#x","Type1",Covariant)]), - checkOperationSuccess - ("testfiles" "inference.0rx") - (\ts -> do - tm <- includeNewTypes defaultCategories ts - checkInferenceSuccess tm - [("#x",[])] ["#x"] -- Guesses are both Type0 and Type1, and Type0 is more general. [("Interface3","[Interface1<#x>&Interface3<#x>]")] - [("#x","Type0",Invariant)]), + [("#x","Type0")]), checkOperationSuccess ("testfiles" "inference.0rx") @@ -971,7 +951,7 @@ [("#x",[])] ["#x"] -- An unrelated union shouldn't cause problems. [("Type1","#x"),("Type2","[Type2|Type0]")] - [("#x","Type1",Covariant)]), + [("#x","Type1")]), checkOperationSuccess ("testfiles" "inference.0rx") @@ -981,9 +961,26 @@ [("#x",[]),("#y",[])] ["#x","#y"] [("Interface3","[Interface1<#x>&Interface3<#x>]"), ("Interface3","[Interface1<#y>|Interface3<#y>]")] - [("#x","Type0",Invariant),("#y","Type1",Covariant)]), + [("#x","Type0"),("#y","Type1")]), checkOperationSuccess + ("testfiles" "inference.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceSuccess tm + [("#x",[])] ["#x"] + [("Interface1","Interface1<#x>")] + [("#x","any")]), + checkOperationSuccess + ("testfiles" "inference.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceSuccess tm + [("#x",[])] ["#x"] + [("Interface2","Interface2<#x>")] + [("#x","all")]), + + checkOperationSuccess ("testfiles" "delayed_merging.0rx") (\ts -> do tm <- includeNewTypes defaultCategories ts @@ -1000,7 +997,133 @@ -- Failure to merge Type1 and Type2 is resolved by Base. [("Base","#x"), ("Type","[Interface1<#x>|Interface2<#x>]")] - [("#x","Base",Covariant)]) + [("#x","Base")]), + + checkOperationSuccess + ("testfiles" "infer_meta.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceSuccess tm + [("#x",[])] ["#x"] + [("[Interface2|Interface3]","Interface0<#x>")] + -- Guesses are Type1 and Type2, and Type1 is more general. + [("#x","Type1")]), + checkOperationSuccess + ("testfiles" "infer_meta.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceSuccess tm + [("#x",[])] ["#x"] + [("[Interface2|Interface3]","Interface0<#x>")] + -- Guesses are Type0 and Type4, which can't be merged. + [("#x","[Type4|Type0]")]), + checkOperationSuccess + ("testfiles" "infer_meta.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceSuccess tm + [("#x",[])] ["#x"] + [("[Interface2&Interface3]","Interface0<#x>")] + -- Guesses are Type1 or Type2, and Type2 is more specific. + [("#x","Type2")]), + checkOperationSuccess + ("testfiles" "infer_meta.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceFail tm + [("#x",[])] ["#x"] + -- Guesses are Type0 or Type4, which can't be merged. + [("[Interface2&Interface3]","Interface0<#x>")]), + checkOperationSuccess + ("testfiles" "infer_meta.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceSuccess tm + [("#x",[])] ["#x"] + [("[Interface2|Interface3]","Interface1<#x>")] + -- Guesses are Type1 and Type2, and Type2 is more general. + [("#x","Type2")]), + checkOperationSuccess + ("testfiles" "infer_meta.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceSuccess tm + [("#x",[])] ["#x"] + [("[Interface2|Interface3]","Interface1<#x>")] + -- Guesses are Type0 and Type4, which can't be merged. + [("#x","[Type4&Type0]")]), + checkOperationSuccess + ("testfiles" "infer_meta.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceSuccess tm + [("#x",[])] ["#x"] + [("[Interface2&Interface3]","Interface1<#x>")] + -- Guesses are Type1 or Type2, and Type1 is more specific. + [("#x","Type1")]), + checkOperationSuccess + ("testfiles" "infer_meta.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceFail tm + [("#x",[])] ["#x"] + -- Guesses are Type0 or Type4, which can't be merged. + [("[Interface2&Interface3]","Interface1<#x>")]), + + checkOperationSuccess + ("testfiles" "infer_meta.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceSuccess tm + [("#x",["requires Type0"])] ["#x"] + -- Guesses are Type1 or Type4, which can't be merged, but the filter + -- eliminates Type4. + [("[Interface2&Interface3]","Interface0<#x>")] + [("#x","Type1")]), + checkOperationSuccess + ("testfiles" "infer_meta.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceSuccess tm + [("#x",["allows Type2"])] ["#x"] + -- Guesses are Type1 or Type4, which can't be merged, but the filter + -- eliminates Type4. + [("[Interface2&Interface3]","Interface0<#x>")] + [("#x","Type1")]), + checkOperationSuccess + ("testfiles" "infer_meta.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceSuccess tm + [("#x",["defines Defined<#x>"])] ["#x"] + -- Guesses are Type1 or Type4, which can't be merged, but the filter + -- eliminates Type1. + [("[Interface2&Interface3]","Interface0<#x>")] + [("#x","Type4")]), + + checkOperationSuccess + ("testfiles" "infer_meta.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceSuccess tm + [("#x",["requires Type0"])] ["#x"] + [("[Type1|Type2]","#x")] + [("#x","[Type1|Type2]")]), + checkOperationSuccess + ("testfiles" "infer_meta.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceSuccess tm + [("#x",["requires #x"])] ["#x"] + [("[Type1|Type2]","#x")] + [("#x","[Type1|Type2]")]), + checkOperationSuccess + ("testfiles" "infer_meta.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceFail tm + [("#x",["requires Type0"])] ["#x"] + [("[Type1|Type4]","#x")]) ] getRefines :: Map.Map CategoryName (AnyCategory c) -> String -> CompileInfo [String] @@ -1070,8 +1193,8 @@ | length actual /= length expected = compileErrorM $ "Different item counts: " ++ show actual ++ " (actual) vs. " ++ show expected ++ " (expected)" - | otherwise = mergeAllM $ map check (zip3 actual expected ([1..] :: [Int])) where - check (a,e,n) = f a e [a] -> [a] -> CompileInfo () containsPaired = checkPaired checkSingle where @@ -1085,7 +1208,7 @@ let parsed = readMulti f contents :: CompileInfo [AnyCategory SourcePos] return $ check (parsed >>= o >> return ()) where - check x = x ([AnyCategory SourcePos] -> CompileInfo a) -> IO (CompileInfo ()) checkOperationFail f o = do @@ -1139,15 +1262,15 @@ show (getCompileSuccess c) ++ "\n" checkInferenceSuccess :: CategoryMap SourcePos -> [(String, [String])] -> - [String] -> [(String, String)] -> [(String,String,Variance)] -> CompileInfo () + [String] -> [(String,String)] -> [(String,String)] -> CompileInfo () checkInferenceSuccess tm pa is ts gs = checkInferenceCommon check tm pa is ts gs where prefix = show ts ++ " " ++ showParams pa check gs2 c - | isCompileError c = compileErrorM $ prefix ++ ":\n" ++ show (getCompileError c) + | isCompileError c = compileErrorM $ prefix ++ ":\n" ++ show (getCompileWarnings c) ++ show (getCompileError c) | otherwise = getCompileSuccess c `containsExactly` gs2 checkInferenceFail :: CategoryMap SourcePos -> [(String, [String])] -> - [String] -> [(String, String)] -> CompileInfo () + [String] -> [(String,String)] -> CompileInfo () checkInferenceFail tm pa is ts = checkInferenceCommon check tm pa is ts [] where prefix = show ts ++ " " ++ showParams pa check _ c @@ -1155,39 +1278,33 @@ | otherwise = compileErrorM $ prefix ++ ": Expected failure\n" checkInferenceCommon :: ([InferredTypeGuess] -> CompileInfo [InferredTypeGuess] -> CompileInfo ()) -> - CategoryMap SourcePos -> [(String, [String])] -> [String] -> - [(String,String)] -> [(String,String,Variance)] -> CompileInfo () -checkInferenceCommon check tm pa is ts gs = checked [(String,[String])] -> [String] -> + [(String,String)] -> [(String,String)] -> CompileInfo () +checkInferenceCommon check tm pa is ts gs = checked not $ k `Set.member` ka) pa2 + let ff = Map.filterWithKey (\k _ -> k `Set.member` ka) pa2 + gs2 <- inferParamTypes r f ia2 ts2 + check gs' $ mergeInferredTypes r f ff ia2 gs2 readInferred p = do p' <- readSingle "(string)" p - return (p',SingleType $ JustInferredType p') - parseGuess (p,t,v) = do + return (p',singleType $ JustInferredType p') + parseGuess (p,t) = do p' <- readSingle "(string)" p t' <- readSingle "(string)" t - return $ InferredTypeGuess p' t' v - parsePair (t1,t2) = do + return $ InferredTypeGuess p' t' Invariant + parsePair im v (t1,t2) = do t1' <- readSingle "(string)" t1 - t2' <- readSingle "(string)" t2 - return (t1',t2') + t2' <- readSingle "(string)" t2 >>= uncheckedSubValueType (weakLookup im) + return (PatternMatch v t1' t2') weakLookup tm2 n = case n `Map.lookup` tm2 of Just t -> return t - Nothing -> return $ SingleType $ JustParamName True n - filterSub im (k,fs) = do - fs' <- mapErrorsM (uncheckedSubFilter (weakLookup im)) fs - return (k,fs') + Nothing -> return $ singleType $ JustParamName True n diff --git a/src/Test/TypeInstance.hs b/src/Test/TypeInstance.hs --- a/src/Test/TypeInstance.hs +++ b/src/Test/TypeInstance.hs @@ -20,6 +20,7 @@ module Test.TypeInstance (tests) where +import Control.Monad (when) import qualified Data.Map as Map import Base.CompileError @@ -36,6 +37,94 @@ tests :: [IO (CompileInfo ())] tests = [ + checkParseSuccess + "Type0" + (singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type0") (Positional [])), + checkParseSuccess + "Type0" + (singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type0") (Positional [ + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type1") (Positional []), + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type2") (Positional []) + ])), + checkParseSuccess + "#x" + (singleType $ JustParamName False $ ParamName "#x"), + checkParseFail "x", + checkParseFail "", + + checkParseSuccess + "[Type0&Type0]" + (singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type0") (Positional [])), + checkParseSuccess + "[Type0|Type0]" + (singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type0") (Positional [])), + checkParseSuccess "all" minBound, + checkParseSuccess "any" maxBound, + checkParseFail "[Type0]", + checkParseFail "[]", + + checkParseSuccess + "[Type1&Type0&Type1]" + (mergeAll [ + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type0") (Positional []), + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type1") (Positional []) + ]), + checkParseSuccess + "[Type1|Type0|Type1]" + (mergeAny [ + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type0") (Positional []), + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type1") (Positional []) + ]), + checkParseFail "[Type0&Type1|Type2]", + checkParseSuccess + "[Type0<#x>&#x]" + (mergeAll [ + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type0") (Positional [ + singleType $ JustParamName False $ ParamName "#x" + ]), + singleType $ JustParamName False $ ParamName "#x" + ]), + checkParseFail "[Type0&]", + checkParseFail "[Type0|]", + checkParseFail "[Type0 Type1]", + + checkParseSuccess + "[Type0&[Type1&Type3]&Type2]" + (mergeAll [ + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type0") (Positional []), + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type1") (Positional []), + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type2") (Positional []), + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type3") (Positional []) + ]), + checkParseSuccess + "[Type0|[Type1|Type3]|Type2]" + (mergeAny [ + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type0") (Positional []), + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type1") (Positional []), + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type2") (Positional []), + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type3") (Positional []) + ]), + checkParseSuccess + "[Type0&[Type1|Type3]&Type2]" + (mergeAll [ + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type0") (Positional []), + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type2") (Positional []), + mergeAny [ + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type1") (Positional []), + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type3") (Positional []) + ] + ]), + checkParseSuccess + "[Type0|[Type1&Type3]|Type2]" + (mergeAny [ + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type0") (Positional []), + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type2") (Positional []), + mergeAll [ + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type1") (Positional []), + singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type3") (Positional []) + ] + ]), + checkSimpleConvertSuccess "Type0" "Type0", @@ -97,7 +186,16 @@ "[Type0|Type3]" "[Type0&Type3]", + -- Make sure that both sides are separately expanded with checks from + -- intersection to union. checkSimpleConvertSuccess + "[Type1&Type4]" + "[[Type1&Type4]|Type5]", + checkSimpleConvertSuccess + "[[Type1|Type4]&Type5]" + "[Type1|Type4]", + + checkSimpleConvertSuccess "any" "any", checkSimpleConvertSuccess @@ -127,6 +225,18 @@ checkSimpleConvertFail "Type1" "Type1", + checkSimpleConvertFail + "Type1" + "Type1", + checkSimpleConvertFail + "Type1" + "Type1", + checkSimpleConvertSuccess + "Type1" + "Type1", + checkSimpleConvertSuccess + "Type1" + "Type1", checkConvertSuccess [("#x",[])] @@ -544,10 +654,6 @@ [("#x",[])] "[[Type4|#x]&Type1]", - return $ checkTypeFail Resolver - [] - "[Type0]", - return $ checkDefinesFail Resolver [("#x",[])] "Instance1<#x>", @@ -574,6 +680,12 @@ checkInferenceSuccess [("#x",[])] ["#x"] + -- Invariant should not be split for non-merged types. + "Type1>>" "Type1>>" + (mergeLeaf ("#x","Type0",Invariant)), + + checkInferenceSuccess + [("#x",[])] ["#x"] "Instance1>" "Instance1<#x>" (mergeLeaf ("#x","Type1",Contravariant)), checkInferenceSuccess @@ -619,8 +731,8 @@ checkInferenceSuccess [("#x",[])] ["#x"] "Instance1>" "Instance1<[#x&Type1<#x>]>" - (mergeAny [mergeLeaf ("#x","Type1",Contravariant), - mergeLeaf ("#x","Type0",Invariant)]), + (mergeAny [mergeLeaf ("#x","Type0",Invariant), + mergeLeaf ("#x","Type1",Contravariant)]), checkInferenceSuccess [("#x",[]),("#y",["allows #x"])] ["#x"] @@ -745,6 +857,18 @@ ]) ] +checkParseSuccess :: String -> GeneralInstance -> IO (CompileInfo ()) +checkParseSuccess x y = return $ do + t <- readSingle "(string)" x IO (CompileInfo ()) +checkParseFail x = return $ do + let t = readSingle "(string)" x :: CompileInfo GeneralInstance + when (not $ isCompileError t) $ + compileErrorM $ "Expected failure to parse " ++ show x ++ + " but got " ++ show (getCompileSuccess t) + checkSimpleConvertSuccess :: String -> String -> IO (CompileInfo ()) checkSimpleConvertSuccess = checkConvertSuccess [] @@ -756,7 +880,7 @@ prefix = x ++ " -> " ++ y ++ " " ++ showParams pa checked = do ([t1,t2],pa2) <- parseTheTest pa [x,y] - check $ checkValueTypeMatch Resolver pa2 t1 t2 + check $ checkValueAssignment Resolver pa2 t1 t2 check c | isCompileError c = compileErrorM $ prefix ++ ":\n" ++ show (getCompileError c) | otherwise = return () @@ -781,7 +905,7 @@ (MergeTree InferredTypeGuess -> CompileInfo (MergeTree InferredTypeGuess) -> CompileInfo ()) -> [(String, [String])] -> [String] -> String -> String -> MergeTree (String,String,Variance) -> IO (CompileInfo ()) -checkInferenceCommon check pa is x y gs = return $ checked return t - Nothing -> return $ SingleType $ JustParamName True n + Nothing -> return $ singleType $ JustParamName True n filterSub im (k,fs) = do fs' <- mapErrorsM (uncheckedSubFilter (weakLookup im)) fs return (k,fs') @@ -812,7 +936,7 @@ prefix = x ++ " /> " ++ y ++ " " ++ showParams pa checked = do ([t1,t2],pa2) <- parseTheTest pa [x,y] - check $ checkValueTypeMatch Resolver pa2 t1 t2 + check $ checkValueAssignment Resolver pa2 t1 t2 check :: CompileInfo a -> CompileInfo () check c | isCompileError c = return () diff --git a/src/Test/testfiles/basic_crash_test.0rt b/src/Test/testfiles/basic_crash_test.0rt --- a/src/Test/testfiles/basic_crash_test.0rt +++ b/src/Test/testfiles/basic_crash_test.0rt @@ -1,5 +1,5 @@ testcase "basic crash test" { - crash Test$execute() + crash Test.execute() require "pattern in output 1" exclude "pattern not in output 1" require "pattern in output 2" diff --git a/src/Test/testfiles/basic_success_test.0rt b/src/Test/testfiles/basic_success_test.0rt --- a/src/Test/testfiles/basic_success_test.0rt +++ b/src/Test/testfiles/basic_success_test.0rt @@ -1,5 +1,5 @@ testcase "basic success test" { - success Test$execute() + success Test.execute() require "pattern in output 1" exclude "pattern not in output 1" require "pattern in output 2" diff --git a/src/Test/testfiles/definitions.0rx b/src/Test/testfiles/definitions.0rx --- a/src/Test/testfiles/definitions.0rx +++ b/src/Test/testfiles/definitions.0rx @@ -1,7 +1,7 @@ define Type { @value T<#x> val - @type Type<#x> zzz <- Type<#x>{ T<#x>$create() } + @type Type<#x> zzz <- Type<#x>{ T<#x>.create() } @category optional T something <- skip diff --git a/src/Test/testfiles/function_filters_satisfied.0rx b/src/Test/testfiles/function_filters_satisfied.0rx --- a/src/Test/testfiles/function_filters_satisfied.0rx +++ b/src/Test/testfiles/function_filters_satisfied.0rx @@ -1,23 +1,23 @@ @type interface Type1<#x> {} -@value interface Type2<#x> {} +@value interface Type2<#x|> {} -@value interface Type3<#x> {} +@value interface Type3<#x|> {} -concrete Type4<#x> { - #x requires Type2<#x> +concrete Type4<#w,#x> { + #w requires Type2<#w> #x allows Type3<#x> - #x defines Type1<#x> + #w defines Type1<#w> - @type something<#y> + @type something<#y,#z> #y requires Type2<#y> - #y allows Type3<#y> + #z allows Type3<#z> #y defines Type1<#y> - () -> (Type4<#y>) + () -> (Type4<#y,#z>) - @type something2<#y> - #y requires #x - #y allows #x + @type something2<#y,#z> + #y requires #w + #z allows #x #y defines Type1<#y> - () -> (Type4<#y>) + () -> (Type4<#y,#z>) } diff --git a/src/Test/testfiles/infer_meta.0rx b/src/Test/testfiles/infer_meta.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/infer_meta.0rx @@ -0,0 +1,29 @@ +@value interface Type0 {} + +@value interface Type1 { + refines Type0 +} + +@value interface Type2 { + refines Type1 +} + +concrete Type4 { + defines Defined +} + +@type interface Defined<#x> {} + +@value interface Interface0<|#x> {} + +@value interface Interface1<#y|> {} + +@value interface Interface2<#y> { + refines Interface0<#y> + refines Interface1<#y> +} + +@value interface Interface3<#y> { + refines Interface0<#y> + refines Interface1<#y> +} diff --git a/src/Test/testfiles/module-config.txt b/src/Test/testfiles/module-config.txt --- a/src/Test/testfiles/module-config.txt +++ b/src/Test/testfiles/module-config.txt @@ -6,7 +6,7 @@ } expression_macro { name: MY_OTHER_MACRO - expression: Type$execute("this is a string\012") + expression: Type.execute("this is a string\012") } ] mode: incremental {} diff --git a/src/Test/testfiles/procedures.0rx b/src/Test/testfiles/procedures.0rx --- a/src/Test/testfiles/procedures.0rx +++ b/src/Test/testfiles/procedures.0rx @@ -1,13 +1,13 @@ testFunction1 (a,b,c) (d,e,f) { - if (T$f()) { + if (T.f()) { // do nothing - } elif (#q$r().f()) { + } elif (#q.r().f()) { \ require(v).g() } elif (zzz) { // sleep } - x <- Type<#z,T<#m>>{ r, Type$new() } + x <- Type<#z,T<#m>>{ r, Type.new() } x <- empty @@ -31,7 +31,7 @@ \ z.call().call() x, weak [#k|Type] y, _ <- z.call() - x <- z.T<#z>$call().call() + x <- z.T<#z>.call().call() return _ return a return a, z.call().call(), c diff --git a/src/Test/testfiles/test.0rt b/src/Test/testfiles/test.0rt --- a/src/Test/testfiles/test.0rt +++ b/src/Test/testfiles/test.0rt @@ -1,5 +1,5 @@ testcase "test" { - success Test$run() + success Test.run() } concrete Test { diff --git a/src/Types/Builtin.hs b/src/Types/Builtin.hs --- a/src/Types/Builtin.hs +++ b/src/Types/Builtin.hs @@ -31,7 +31,6 @@ import qualified Data.Map as Map -import Types.GeneralType import Types.TypeCategory import Types.TypeInstance @@ -52,4 +51,4 @@ formattedRequiredValue :: ValueType formattedRequiredValue = requiredSingleton BuiltinFormatted emptyValue :: ValueType -emptyValue = ValueType OptionalValue $ TypeMerge MergeUnion [] +emptyValue = ValueType OptionalValue minBound diff --git a/src/Types/DefinedCategory.hs b/src/Types/DefinedCategory.hs --- a/src/Types/DefinedCategory.hs +++ b/src/Types/DefinedCategory.hs @@ -33,7 +33,6 @@ import qualified Data.Set as Set import Base.CompileError -import Base.Mergeable import Types.Function import Types.Positional import Types.Procedure @@ -78,14 +77,15 @@ vvWritable :: Bool } -setInternalFunctions :: (Show c, CompileErrorM m, MergeableM m, TypeResolver r) => +setInternalFunctions :: (Show c, CompileErrorM m, TypeResolver r) => r -> AnyCategory c -> [ScopedFunction c] -> m (Map.Map FunctionName (ScopedFunction c)) -setInternalFunctions r t fs = foldr update (return start) fs where +setInternalFunctions r t fs = do + fm <- getCategoryFilterMap t + foldr (update fm) (return start) fs where start = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions t - fm = getCategoryFilterMap t pm = getCategoryParamMap t - update f@(ScopedFunction c n t2 s as rs ps fs2 ms) fa = do + update fm f@(ScopedFunction c n t2 s as rs ps fs2 ms) fa = do validateCategoryFunction r t f fa' <- fa case n `Map.lookup` fa' of @@ -98,7 +98,7 @@ checkFunctionConvert r fm pm f0' f' return $ Map.insert n (ScopedFunction (c++c2) n t2 s as rs ps fs2 ([f0]++ms++ms2)) fa' -pairProceduresToFunctions :: (Show c, CompileErrorM m, MergeableM m) => +pairProceduresToFunctions :: (Show c, CompileErrorM m) => Map.Map FunctionName (ScopedFunction c) -> [ExecutableProcedure c] -> m [(ScopedFunction c,ExecutableProcedure c)] pairProceduresToFunctions fa ps = do @@ -129,7 +129,7 @@ formatFullContextBrace (epContext p) ++ " does not correspond to a function" getPair (Just f) (Just p) = do - processPairs_ alwaysPair (sfArgs f) (avNames $ epArgs p) +mapMembers :: (Show c, CompileErrorM m) => [DefinedMember c] -> m (Map.Map VariableName (VariableValue c)) mapMembers ms = foldr update (return Map.empty) ms where update m ma = do @@ -161,7 +161,7 @@ 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) => +mergeInternalInheritance :: (Show c, CompileErrorM m) => CategoryMap c -> DefinedCategory c -> m (CategoryMap c) mergeInternalInheritance tm d = do let rs2 = dcRefines d @@ -170,7 +170,7 @@ 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 + fm <- getCategoryFilterMap t let pm = getCategoryParamMap t rs' <- mergeRefines r fm (rs++rs2) noDuplicateRefines [] n rs' diff --git a/src/Types/Function.hs b/src/Types/Function.hs --- a/src/Types/Function.hs +++ b/src/Types/Function.hs @@ -30,7 +30,6 @@ import qualified Data.Map as Map import Base.CompileError -import Base.Mergeable import Types.GeneralType import Types.Positional import Types.TypeInstance @@ -55,18 +54,18 @@ where showFilters (n,fs) = map (\f -> show n ++ " " ++ show f ++ " ") fs -validatateFunctionType :: (MergeableM m, CompileErrorM m, TypeResolver r) => +validatateFunctionType :: (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 + mapErrorsM_ checkCount $ group $ sort $ pValues ps + mapErrorsM_ 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 + mapErrorsM_ (checkFilterType allFilters) expanded + mapErrorsM_ checkFilterVariance expanded + mapErrorsM_ (checkArg allFilters) $ pValues as + mapErrorsM_ (checkReturn allFilters) $ pValues rs where allVariances = Map.union vm (Map.fromList $ zip (pValues ps) (repeat Invariant)) checkCount xa@(x:_:_) = @@ -78,10 +77,10 @@ checkFilterType fa2 (n,f) = validateTypeFilter r fa2 f +assignFunctionParams :: (CompileErrorM m, TypeResolver r) => r -> ParamFilters -> ParamValues -> Positional GeneralInstance -> FunctionType -> m FunctionType assignFunctionParams r fm pm ts (FunctionType as rs ps fa) = do - mergeAllM $ map (validateGeneralInstance r fm) $ pValues ts + mapErrorsM_ (validateGeneralInstance r fm) $ pValues ts assigned <- fmap Map.fromList $ processPairs alwaysPair ps ts let pa = pm `Map.union` assigned fa' <- fmap Positional $ mapErrorsM (assignFilters pa) (pValues fa) @@ -112,12 +111,12 @@ where assignFilters fm2 fs = mapErrorsM (uncheckedSubFilter $ getValueForParam fm2) fs -checkFunctionConvert :: (MergeableM m, CompileErrorM m, TypeResolver r) => +checkFunctionConvert :: (CompileErrorM m, TypeResolver r) => r -> ParamFilters -> ParamValues -> FunctionType -> FunctionType -> m () checkFunctionConvert r fm pm (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 False) $ pValues ps1 + let asTypes = Positional $ map (singleType . JustParamName False) $ pValues ps1 -- Substitute params from ff2 into ff1. (FunctionType as2 rs2 _ _) <- assignFunctionParams r fm' pm asTypes ff2 fixed <- processPairs alwaysPair ps1 fa1 @@ -125,5 +124,5 @@ processPairs_ (validateArg fm'') as1 as2 processPairs_ (validateReturn fm'') rs1 rs2 where - validateArg fm2 a1 a2 = checkValueTypeMatch r fm2 a1 a2 - validateReturn fm2 r1 r2 = checkValueTypeMatch r fm2 r2 r1 + validateArg fm2 a1 a2 = checkValueAssignment r fm2 a1 a2 + validateReturn fm2 r1 r2 = checkValueAssignment r fm2 r2 r1 diff --git a/src/Types/GeneralType.hs b/src/Types/GeneralType.hs --- a/src/Types/GeneralType.hs +++ b/src/Types/GeneralType.hs @@ -17,36 +17,62 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com] {-# LANGUAGE Safe #-} +{-# LANGUAGE TypeFamilies #-} module Types.GeneralType ( - GeneralType(..), - MergeType(..), - checkGeneralType, + GeneralType, + dualGeneralType, + mapGeneralType, + singleType, ) where +import qualified Data.Set as Set + +import Base.MergeTree import Base.Mergeable -data MergeType = - MergeUnion | - MergeIntersect - deriving (Eq,Ord) - data GeneralType a = SingleType { stType :: a } | - TypeMerge { - tmMerge :: MergeType, - tmTypes :: [GeneralType a] + AllowAnyOf { + aaoTypes :: Set.Set (GeneralType a) + } | + RequireAllOf { + raoTypes :: Set.Set (GeneralType a) } deriving (Eq,Ord) -checkGeneralType :: (MergeableM m, Mergeable c) => (a -> b -> m c) -> GeneralType a -> GeneralType b -> m c -checkGeneralType f = singleCheck 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 +singleType :: (Eq a, Ord a) => a -> GeneralType a +singleType = SingleType + +instance (Eq a, Ord a) => Mergeable (GeneralType a) where + mergeAny = unnest . foldr (Set.union . flattenAny) Set.empty where + flattenAny (AllowAnyOf xs) = xs + flattenAny x = Set.fromList [x] + unnest xs = case Set.toList xs of + [x] -> x + _ -> AllowAnyOf xs + mergeAll = unnest . foldr (Set.union . flattenAll) Set.empty where + flattenAll (RequireAllOf xs) = xs + flattenAll x = Set.fromList [x] + unnest xs = case Set.toList xs of + [x] -> x + _ -> RequireAllOf xs + +instance (Eq a, Ord a) => PreserveMerge (GeneralType a) where + type T (GeneralType a) = a + convertMerge f (AllowAnyOf xs) = mergeAny $ map (convertMerge f) $ Set.toList xs + convertMerge f (RequireAllOf xs) = mergeAll $ map (convertMerge f) $ Set.toList xs + convertMerge f (SingleType x) = f x + +instance (Eq a, Ord a) => Bounded (GeneralType a) where + minBound = mergeAny Nothing -- all + maxBound = mergeAll Nothing -- any + +dualGeneralType :: (Eq a, Ord a) => GeneralType a -> GeneralType a +dualGeneralType = reduceMergeTree mergeAll mergeAny singleType + +mapGeneralType :: (Eq a, Ord a, Eq b, Ord b) => (a -> b) -> GeneralType a -> GeneralType b +mapGeneralType = reduceMergeTree mergeAny mergeAll . (singleType .) diff --git a/src/Types/Procedure.hs b/src/Types/Procedure.hs --- a/src/Types/Procedure.hs +++ b/src/Types/Procedure.hs @@ -45,6 +45,7 @@ getExpressionContext, getStatementContext, isDiscardedInput, + isLiteralCategory, isUnnamedReturns, ) where @@ -264,6 +265,14 @@ getValueLiteralContext (DecimalLiteral c _ _) = c getValueLiteralContext (BoolLiteral c _) = c getValueLiteralContext (EmptyLiteral c) = c + +isLiteralCategory :: CategoryName -> Bool +isLiteralCategory BuiltinBool = True +isLiteralCategory BuiltinChar = True +isLiteralCategory BuiltinInt = True +isLiteralCategory BuiltinFloat = True +isLiteralCategory BuiltinString = True +isLiteralCategory _ = False data ValueOperation c = ConvertedCall [c] TypeInstance (FunctionCall c) | diff --git a/src/Types/TypeCategory.hs b/src/Types/TypeCategory.hs --- a/src/Types/TypeCategory.hs +++ b/src/Types/TypeCategory.hs @@ -17,6 +17,7 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com] {-# LANGUAGE Safe #-} +{-# LANGUAGE TypeFamilies #-} module Types.TypeCategory ( AnyCategory(..), @@ -26,6 +27,7 @@ Namespace(..), ParamFilter(..), PassedValue(..), + PatternMatch(..), ScopedFunction(..), SymbolScope(..), ValueDefine(..), @@ -56,11 +58,13 @@ getFunctionFilterMap, getInstanceCategory, getValueCategory, + guessesAsParams, includeNewTypes, inferParamTypes, isInstanceInterface, - isDynamicNamespace, isNoNamespace, + isPrivateNamespace, + isPublicNamespace, isStaticNamespace, isValueConcrete, isValueInterface, @@ -79,9 +83,8 @@ ) where import Control.Arrow (second) -import Control.Monad (when) -import Data.Functor.Identity (runIdentity) -import Data.List (group,groupBy,intercalate,sort,sortBy) +import Control.Monad ((>=>),when) +import Data.List (group,groupBy,intercalate,nub,sort,sortBy) import qualified Data.Map as Map import qualified Data.Set as Set @@ -219,17 +222,16 @@ 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 + 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 _ = [] + fromInstance = reduceMergeTree concat concat fromSingle + fromSingle (JustTypeInstance (TypeInstance n ps)) = n:(concat $ map fromInstance $ pValues ps) + fromSingle _ = [] fromDefine (DefinesInstance n ps) = n:(concat $ map fromInstance $ pValues ps) - fromFilter (TypeFilter _ t2@(JustTypeInstance _)) = fromInstance (SingleType t2) - fromFilter (DefinesFilter t2) = fromDefine t2 - fromFilter _ = [] + fromFilter (TypeFilter _ t2) = fromInstance t2 + fromFilter (DefinesFilter t2) = fromDefine t2 fromType (ValueType _ t2) = fromInstance t2 fromFunction f = args ++ returns ++ filters2 where args = concat $ map (fromType . pvType) $ pValues $ sfArgs f @@ -253,7 +255,8 @@ snName :: String } | NoNamespace | - DynamicNamespace + PublicNamespace | + PrivateNamespace deriving (Eq,Ord) instance Show Namespace where @@ -268,10 +271,14 @@ isNoNamespace NoNamespace = True isNoNamespace _ = False -isDynamicNamespace :: Namespace -> Bool -isDynamicNamespace DynamicNamespace = True -isDynamicNamespace _ = False +isPublicNamespace :: Namespace -> Bool +isPublicNamespace PublicNamespace = True +isPublicNamespace _ = False +isPrivateNamespace :: Namespace -> Bool +isPrivateNamespace PrivateNamespace = True +isPrivateNamespace _ = False + data ValueRefine c = ValueRefine { vrContext :: [c], @@ -315,7 +322,7 @@ crCategories :: CategoryMap c } -instance (Show c) => TypeResolver (CategoryResolver c) where +instance Show c => TypeResolver (CategoryResolver c) where trRefines (CategoryResolver tm) (TypeInstance n1 ps1) n2 | n1 == n2 = do (_,t) <- getValueCategory tm ([],n1) @@ -374,7 +381,7 @@ | f x == ValueScope = (cs,ts,x:vs) | otherwise = (cs,ts,vs) -checkFilters :: (CompileErrorM m, MergeableM m) => +checkFilters :: CompileErrorM m => AnyCategory c -> Positional GeneralInstance -> m (Positional [TypeFilter]) checkFilters t ps = do let params = map vpParam $ getCategoryParams t @@ -384,7 +391,7 @@ let fa = Map.fromListWith (++) $ map (second (:[])) fs fmap Positional $ mapErrorsM (assignFilter fa) params where subSingleFilter pa (n,(TypeFilter v t2)) = do - (SingleType t3) <- uncheckedSubInstance (getValueForParam pa) (SingleType t2) + t3<- uncheckedSubInstance (getValueForParam pa) t2 return (n,(TypeFilter v t3)) subSingleFilter pa (n,(DefinesFilter (DefinesInstance n2 ps2))) = do ps3 <- mapErrorsM (uncheckedSubInstance $ getValueForParam pa) (pValues ps2) @@ -394,7 +401,7 @@ (Just x) -> return x _ -> return [] -subAllParams :: (MergeableM m, CompileErrorM m) => +subAllParams :: CompileErrorM m => ParamValues -> GeneralInstance -> m GeneralInstance subAllParams pa = uncheckedSubInstance (getValueForParam pa) @@ -441,7 +448,7 @@ " cannot be used as concrete" ++ formatFullContextBrace c -includeNewTypes :: (Show c, MergeableM m, CompileErrorM m) => +includeNewTypes :: (Show c, CompileErrorM m) => CategoryMap c -> [AnyCategory c] -> m (CategoryMap c) includeNewTypes tm0 ts = do checkConnectionCycles tm0 ts @@ -463,43 +470,72 @@ formatFullContextBrace (getCategoryContext t2) _ -> return $ Map.insert (getCategoryName t) t tm -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 +getFilterMap :: CompileErrorM m => [ValueParam c] -> [ParamFilter c] -> m ParamFilters +getFilterMap ps fs = do + mirrored <- fmap concat $ mapErrorsM maybeMirror fs + return $ getFilters mirrored $ zip (Set.toList pa) (repeat []) where + pa = Set.fromList $ map vpParam ps + maybeMirror fa@(ParamFilter c p1 (TypeFilter d p2)) = do + p <- collectFirstM [fmap Just $ matchOnlyLeaf p2,return Nothing] + case p of + Just (JustParamName _ p') -> + if p' `Set.member` pa + then return [fa,(ParamFilter c p' (TypeFilter (flipFilter d) (singleType (JustParamName False p1))))] + else return [fa] + _ -> return [fa] + maybeMirror fa = return [fa] + getFilters fs2 pa0 = let fs' = map (\f -> (pfParam f,pfFilter f)) fs2 in + Map.fromListWith (++) $ map (second (:[])) fs' ++ pa0 -getCategoryFilterMap :: AnyCategory c -> ParamFilters +getCategoryFilterMap :: CompileErrorM m => AnyCategory c -> m ParamFilters getCategoryFilterMap t = getFilterMap (getCategoryParams t) (getCategoryFilters t) +-- TODO: Use this where it's needed in this file. +getFunctionFilterMap :: CompileErrorM m => ScopedFunction c -> m ParamFilters +getFunctionFilterMap f = getFilterMap (pValues $ sfParams f) (sfFilters f) + getCategoryParamMap :: AnyCategory c -> ParamValues getCategoryParamMap t = let ps = map vpParam $ getCategoryParams t in - Map.fromList $ zip ps (map (SingleType . JustParamName False) ps) + Map.fromList $ zip ps (map (singleType . JustParamName False) ps) --- TODO: Use this where it's needed in this file. -getFunctionFilterMap :: ScopedFunction c -> ParamFilters -getFunctionFilterMap f = getFilterMap (pValues $ sfParams f) (sfFilters f) +disallowBoundedParams :: CompileErrorM m => ParamFilters -> m () +disallowBoundedParams = mapErrorsM_ checkBounds . Map.toList where + checkBounds (p,fs) = do + let bs = splitBounds fs + case bs of + ([],_) -> return () + (_,[]) -> return () + (ls,hs) -> ("Param " ++ show p ++ " cannot have both lower and upper bounds") !!> + collectAllM_ [ + mapErrorsM_ (filterAsError p) ls +checkConnectedTypes :: (Show c, CompileErrorM m) => CategoryMap c -> [AnyCategory c] -> m () checkConnectedTypes tm0 ts = do tm <- declareAllTypes tm0 ts - mergeAllM (map (checkSingle tm) ts) + collectAllM_ (map (checkSingle tm) ts) where checkSingle tm (ValueInterface c _ n _ rs _ _) = do let ts2 = map (\r -> (vrContext r,tiName $ vrType r)) rs is <- mapErrorsM (getCategory tm) ts2 - mergeAllM (map (valueRefinesInstanceError c n) is) - mergeAllM (map (valueRefinesConcreteError c n) is) + collectAllM_ (map (valueRefinesInstanceError c n) is) + collectAllM_ (map (valueRefinesConcreteError c n) is) checkSingle tm (ValueConcrete c _ n _ rs ds _ _) = do let ts2 = map (\r -> (vrContext r,tiName $ vrType r)) rs let ts3 = map (\d -> (vdContext d,diName $ vdType d)) ds is1 <- mapErrorsM (getCategory tm) ts2 is2 <- mapErrorsM (getCategory tm) ts3 - mergeAllM (map (concreteRefinesInstanceError c n) is1) - mergeAllM (map (concreteDefinesValueError c n) is2) - mergeAllM (map (concreteRefinesConcreteError c n) is1) - mergeAllM (map (concreteDefinesConcreteError c n) is2) + collectAllM_ (map (concreteRefinesInstanceError c n) is1) + collectAllM_ (map (concreteDefinesValueError c n) is2) + collectAllM_ (map (concreteRefinesConcreteError c n) is1) + collectAllM_ (map (concreteDefinesConcreteError c n) is2) checkSingle _ _ = return () valueRefinesInstanceError c n (c2,t) | isInstanceInterface t = @@ -540,20 +576,20 @@ show (getCategoryName t) ++ formatFullContextBrace c2 | otherwise = return () -checkConnectionCycles :: (Show c, MergeableM m, CompileErrorM m) => +checkConnectionCycles :: (Show c, CompileErrorM m) => CategoryMap c -> [AnyCategory c] -> m () -checkConnectionCycles tm0 ts = mergeAllM (map (checker []) ts) where +checkConnectionCycles tm0 ts = collectAllM_ (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 ts2 = map (\r -> (vrContext r,tiName $ vrType r)) rs is <- mapErrorsM (getValueCategory tm) ts2 - mergeAllM (map (checker (us ++ [n]) . snd) is) + collectAllM_ (map (checker (us ++ [n]) . snd) is) checker us (ValueConcrete c _ n _ rs _ _ _) = do failIfCycle n c us let ts2 = map (\r -> (vrContext r,tiName $ vrType r)) rs is <- mapErrorsM (getValueCategory tm) ts2 - mergeAllM (map (checker (us ++ [n]) . snd) is) + collectAllM_ (map (checker (us ++ [n]) . snd) is) checker _ _ = return () failIfCycle n c us = when (n `Set.member` (Set.fromList us)) $ @@ -561,39 +597,43 @@ " refers back to itself: " ++ intercalate " -> " (map show (us ++ [n])) -checkParamVariances :: (Show c, MergeableM m, CompileErrorM m) => +checkParamVariances :: (Show c, CompileErrorM m) => CategoryMap c -> [AnyCategory c] -> m () checkParamVariances tm0 ts = do tm <- declareAllTypes tm0 ts let r = CategoryResolver tm - mergeAllM (map (checkCategory r) ts) + mapErrorsM_ (checkCategory r) ts + mapErrorsM_ checkBounds ts where - checkCategory r (ValueInterface c _ n ps rs fa _) = do + categoryContext t = + "In " ++ show (getCategoryName t) ++ formatFullContextBrace (getCategoryContext t) + checkBounds t = categoryContext t ??> (getCategoryFilterMap t >>= disallowBoundedParams) + checkCategory r t@(ValueInterface c _ n ps rs fa _) = categoryContext t ??> 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 + collectAllM_ (map (checkRefine r vm) rs) + mapErrorsM_ (checkFilterVariance r vm) fa + checkCategory r t@(ValueConcrete c _ n ps rs ds fa _) = categoryContext t ??> 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 + collectAllM_ (map (checkRefine r vm) rs) + collectAllM_ (map (checkDefine r vm) ds) + mapErrorsM_ (checkFilterVariance r vm) fa + checkCategory r t@(InstanceInterface c _ n ps fa _) = categoryContext t ??> 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 + mapErrorsM_ (checkFilterVariance r vm) fa + noDuplicates c n ps = collectAllM_ (map checkCount $ group $ sort $ map vpParam ps) where checkCount xa@(x:_:_) = compileErrorM $ "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) do case n `Map.lookup` vs of @@ -601,7 +641,7 @@ " cannot have a requires filter" Nothing -> compileErrorM $ "Param " ++ show n ++ " is undefined" _ -> return () - validateInstanceVariance r vs Contravariant (SingleType t) + validateInstanceVariance r vs Contravariant t checkFilterVariance r vs (ParamFilter c n f@(TypeFilter FilterAllows t)) = ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) ??> do case n `Map.lookup` vs of @@ -609,7 +649,7 @@ " cannot have an allows filter" Nothing -> compileErrorM $ "Param " ++ show n ++ " is undefined" _ -> return () - validateInstanceVariance r vs Covariant (SingleType t) + validateInstanceVariance r vs Covariant t checkFilterVariance r vs (ParamFilter c n f@(DefinesFilter t)) = ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) ??> do case n `Map.lookup` vs of @@ -619,38 +659,38 @@ _ -> return () validateDefinesVariance r vs Contravariant t -checkCategoryInstances :: (Show c, MergeableM m, CompileErrorM m) => +checkCategoryInstances :: (Show c, CompileErrorM m) => CategoryMap c -> [AnyCategory c] -> m () checkCategoryInstances tm0 ts = do tm <- declareAllTypes tm0 ts let r = CategoryResolver tm - mergeAllM $ map (checkSingle r) ts + mapErrorsM_ (checkSingle r) ts where checkSingle r t = do let pa = Set.fromList $ map vpParam $ getCategoryParams t - let fm = getCategoryFilterMap 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) + fm <- getCategoryFilterMap t + mapErrorsM_ (checkFilterParam pa) (getCategoryFilters t) + mapErrorsM_ (checkRefine r fm) (getCategoryRefines t) + mapErrorsM_ (checkDefine r fm) (getCategoryDefines t) + mapErrorsM_ (checkFilter r fm) (getCategoryFilters t) + mapErrorsM_ (validateCategoryFunction r t) (getCategoryFunctions t) checkFilterParam pa (ParamFilter c n _) = when (not $ n `Set.member` pa) $ compileErrorM $ "Param " ++ show n ++ formatFullContextBrace c ++ " does not exist" checkRefine r fm (ValueRefine c t) = validateTypeInstance r fm t +validateCategoryFunction :: (Show c, CompileErrorM m, TypeResolver r) => r -> AnyCategory c -> ScopedFunction c -> m () validateCategoryFunction r t f = do - let fm = getCategoryFilterMap t + fm <- getCategoryFilterMap t let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t message ??> do funcType <- parsedToFunctionType f @@ -659,13 +699,13 @@ TypeScope -> validatateFunctionType r fm vm funcType ValueScope -> validatateFunctionType r fm vm funcType _ -> return () - where + getFunctionFilterMap f >>= disallowBoundedParams where message | getCategoryName t == sfType f = "In function:\n---\n" ++ show f ++ "\n---\n" | otherwise = "In function inherited from " ++ show (sfType f) ++ formatFullContextBrace (getCategoryContext t) ++ ":\n---\n" ++ show f ++ "\n---\n" -topoSortCategories :: (Show c, MergeableM m, CompileErrorM m) => +topoSortCategories :: (Show c, CompileErrorM m) => CategoryMap c -> [AnyCategory c] -> m [AnyCategory c] topoSortCategories tm0 ts = do tm <- declareAllTypes tm0 ts @@ -682,26 +722,26 @@ return (ts3 ++ [t] ++ ts4,ta3) update _ ta _ = return ([],ta) -mergeObjects :: (MergeableM m, CompileErrorM m) => - (a -> a -> m b) -> [a] -> m [a] +-- For fixed x, if f y x succeeds for some y then x is removed. +mergeObjects :: CompileErrorM m => (a -> a -> m b) -> [a] -> m [a] mergeObjects f = merge [] where merge cs [] = return cs merge cs (x:xs) = do - ys <- collectOneOrErrorM $ map check (cs ++ xs) ++ [return [x]] + ys <- collectFirstM $ map check (cs ++ xs) ++ [return [x]] merge (cs ++ ys) xs where check x2 = x2 `f` x >> return [] -mergeRefines :: (MergeableM m, CompileErrorM m, TypeResolver r) => +mergeRefines :: (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 = compileErrorM $ show t1 ++ " and " ++ show t2 ++ " are incompatible" | otherwise = noInferredTypes $ checkGeneralMatch r f Covariant - (SingleType $ JustTypeInstance $ t1) - (SingleType $ JustTypeInstance $ t2) + (singleType $ JustTypeInstance $ t1) + (singleType $ JustTypeInstance $ t2) -mergeDefines :: (MergeableM m, CompileErrorM m, TypeResolver r) => +mergeDefines :: (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 _)) @@ -710,22 +750,22 @@ checkDefinesMatch r f t1 t2 return () -noDuplicateRefines :: (Show c, MergeableM m, CompileErrorM m) => +noDuplicateRefines :: (Show c, CompileErrorM m) => [c] -> CategoryName -> [ValueRefine c] -> m () noDuplicateRefines c n rs = do let names = map (\r -> (tiName $ vrType r,r)) rs noDuplicateCategories c n names -noDuplicateDefines :: (Show c, MergeableM m, CompileErrorM m) => +noDuplicateDefines :: (Show c, CompileErrorM m) => [c] -> CategoryName -> [ValueDefine c] -> m () noDuplicateDefines c n ds = do let names = map (\d -> (diName $ vdType d,d)) ds noDuplicateCategories c n names -noDuplicateCategories :: (Show c, Show a, MergeableM m, CompileErrorM m) => +noDuplicateCategories :: (Show c, Show a, CompileErrorM m) => [c] -> CategoryName -> [(CategoryName,a)] -> m () noDuplicateCategories c n ns = - mergeAllM $ map checkCount $ groupBy (\x y -> fst x == fst y) $ + mapErrorsM_ checkCount $ groupBy (\x y -> fst x == fst y) $ sortBy (\x y -> fst x `compare` fst y) ns where checkCount xa@(x:_:_) = compileErrorM $ "Category " ++ show (fst x) ++ " occurs " ++ show (length xa) ++ @@ -733,7 +773,7 @@ intercalate "\n---\n" (map (show . snd) xa) checkCount _ = return () -flattenAllConnections :: (Show c, MergeableM m, CompileErrorM m) => +flattenAllConnections :: (Show c, 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. @@ -760,7 +800,7 @@ formatFullContextBrace (getCategoryContext t)) return (ts2 ++ [t'],Map.insert (getCategoryName t') t' tm) updateSingle r tm t@(ValueInterface c ns n ps rs vs fs) = do - let fm = getCategoryFilterMap t + fm <- getCategoryFilterMap t let pm = getCategoryParamMap t rs' <- fmap concat $ mapErrorsM (getRefines tm) rs rs'' <- mergeRefines r fm rs' @@ -771,7 +811,7 @@ 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 + fm <- getCategoryFilterMap t let pm = getCategoryParamMap t rs' <- fmap concat $ mapErrorsM (getRefines tm) rs rs'' <- mergeRefines r fm rs' @@ -789,8 +829,7 @@ pa <- assignParams tm c t fmap (ra:) $ mapErrorsM (subAll c pa) refines subAll c pa (ValueRefine c1 t1) = do - (SingleType (JustTypeInstance t2)) <- - uncheckedSubInstance (getValueForParam pa) (SingleType (JustTypeInstance t1)) + t2 <- uncheckedSubSingle (getValueForParam pa) t1 return $ ValueRefine (c ++ c1) t2 assignParams tm c (TypeInstance n ps) = do (_,v) <- getValueCategory tm (c,n) @@ -799,16 +838,16 @@ 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 + mapErrorsM_ (\t -> checkConvert r fm (tiName (vrType t) `Map.lookup` rm) t) rs2 checkConvert r fm (Just ta1@(ValueRefine _ t1)) ta2@(ValueRefine _ t2) = do noInferredTypes $ checkGeneralMatch r fm Covariant - (SingleType $ JustTypeInstance t1) - (SingleType $ JustTypeInstance t2) +mergeFunctions :: (Show c, CompileErrorM m, TypeResolver r) => r -> CategoryMap c -> ParamValues -> ParamFilters -> [ValueRefine c] -> [ValueDefine c] -> [ScopedFunction c] -> m [ScopedFunction c] mergeFunctions r tm pm fm rs ds fs = do @@ -849,7 +888,7 @@ intercalate "\n---\n" (map show es) | otherwise = do let ff@(ScopedFunction c n2 t s as rs2 ps fa ms) = head es - mergeAllM $ map (checkMerge r2 fm2 ff) is + mapErrorsM_ (checkMerge r2 fm2 ff) is return $ ScopedFunction c n2 t s as rs2 ps fa (ms ++ is) where checkMerge r3 fm3 f1 f2 @@ -927,13 +966,13 @@ instance Show c => Show (PassedValue c) where show (PassedValue c t) = show t ++ formatFullContextBrace c -parsedToFunctionType :: (Show c, MergeableM m, CompileErrorM m) => +parsedToFunctionType :: (Show c, CompileErrorM m) => ScopedFunction c -> m FunctionType parsedToFunctionType (ScopedFunction c n _ _ 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 + mapErrorsM_ 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' @@ -949,15 +988,15 @@ (Just fs) -> fs _ -> [] -uncheckedSubFunction :: (Show c, MergeableM m, CompileErrorM m) => +uncheckedSubFunction :: (Show c, CompileErrorM m) => ParamValues -> ScopedFunction c -> m (ScopedFunction c) uncheckedSubFunction = unfixedSubFunction . fmap fixTypeParams -unfixedSubFunction :: (Show c, MergeableM m, CompileErrorM m) => +unfixedSubFunction :: (Show c, CompileErrorM m) => ParamValues -> ScopedFunction c -> m (ScopedFunction c) unfixedSubFunction pa ff@(ScopedFunction c n t s as rs ps fa ms) = ("In function:\n---\n" ++ show ff ++ "\n---\n") ??> do - let unresolved = Map.fromList $ map (\n2 -> (n2,SingleType $ JustParamName False n2)) $ map vpParam $ pValues ps + let unresolved = Map.fromList $ map (\n2 -> (n2,singleType $ JustParamName False n2)) $ map vpParam $ pValues ps let pa' = pa `Map.union` unresolved as' <- fmap Positional $ mapErrorsM (subPassed pa') $ pValues as rs' <- fmap Positional $ mapErrorsM (subPassed pa') $ pValues rs @@ -972,67 +1011,149 @@ f' <- uncheckedSubFilter (getValueForParam pa2) f return $ ParamFilter c2 n2 f' -inferParamTypes :: (MergeableM m, CompileErrorM m, TypeResolver r) => - r -> ParamFilters -> ParamFilters -> ParamValues -> - [(ValueType,ValueType)] -> m (ParamValues) -inferParamTypes r f ff ps ts = do +data PatternMatch a = + PatternMatch { + pmVariance :: Variance, + pmData :: a, + pmPattern :: a + } + +instance Show a => Show (PatternMatch a) where + show (PatternMatch Covariant l r) = show l ++ " -> " ++ show r + show (PatternMatch Contravariant l r) = show l ++ " <- " ++ show r + show (PatternMatch Invariant l r) = show l ++ " <-> " ++ show r + +inferParamTypes :: (CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> ParamValues -> [PatternMatch ValueType] -> + m (MergeTree InferredTypeGuess) +inferParamTypes r f ps ts = do ts2 <- mapErrorsM subAll ts - ff2 <- fmap Map.fromList $ mapErrorsM filterSub $ Map.toList ff - gs <- mergeAllM $ map (uncurry $ checkValueTypeMatch r f) ts2 - let gs2 = concat $ map (filtersToGuess ff2) $ Map.elems ps - let gs3 = mergeAll $ gs:(map mergeLeaf gs2) - gs4 <- mergeInferredTypes r f gs3 - let ga = Map.fromList $ zip (map itgParam gs4) (map itgGuess gs4) - return $ ga `Map.union` ps where - subAll (t1,t2) = do + fmap mergeAll $ mapErrorsM matchPattern ts2 where + subAll (PatternMatch v t1 t2) = do t2' <- uncheckedSubValueType (getValueForParam ps) t2 - return (t1,t2') - filterSub (k,fs) = do - fs' <- mapErrorsM (uncheckedSubFilter (getValueForParam ps)) fs - return (k,fs') - filtersToGuess f2 (SingleType (JustInferredType p)) = - case p `Map.lookup` f2 of - Nothing -> [] - Just fs -> concat $ map (filterToGuess p) fs - filtersToGuess _ _ = [] - filterToGuess p (TypeFilter FilterRequires t) - | hasInferredParams (SingleType t) = [] - | otherwise = [InferredTypeGuess p (SingleType t) Contravariant] - filterToGuess p (TypeFilter FilterAllows t) - | hasInferredParams (SingleType t) = [] - | otherwise = [InferredTypeGuess p (SingleType t) Covariant] - filterToGuess _ _ = [] + return (PatternMatch v t1 t2') + matchPattern (PatternMatch v t1 t2) = checkValueTypeMatch r f v t1 t2 -separateParamGuesses :: MergeableM m => MergeTree InferredTypeGuess -> - m (Map.Map ParamName (MergeTree InferredTypeGuess)) -separateParamGuesses = reduceMergeTree return return (return . toMap) where - toMap i = Map.fromList [(itgParam i,mergeLeaf i)] +guessesAsParams :: [InferredTypeGuess] -> ParamValues +guessesAsParams gs = Map.fromList $ zip (map itgParam gs) (map itgGuess gs) -mergeInferredTypes :: (MergeableM m, CompileErrorM m, TypeResolver r) => - r -> ParamFilters -> MergeTree InferredTypeGuess -> m [InferredTypeGuess] -mergeInferredTypes r f gs = do - let gs' = runIdentity $ separateParamGuesses gs - mapErrorsM reduce $ Map.toList gs' where +data GuessRange a = + GuessRange { + grLower :: a, + grUpper :: a + } + deriving (Eq,Ord) + +instance Show a => Show (GuessRange a) where + show (GuessRange lo hi) = "Something between " ++ show lo ++ " and " ++ show hi + +data GuessUnion a = + GuessUnion { + guGuesses :: [GuessRange a] + } + +mergeInferredTypes :: (CompileErrorM m, TypeResolver r) => + r -> ParamFilters -> ParamFilters -> ParamValues -> MergeTree InferredTypeGuess -> + m [InferredTypeGuess] +mergeInferredTypes r f ff ps gs0 = do + let gs0' = mapTypeGuesses gs0 + mapErrorsM reduce $ Map.toList gs0' where reduce (i,is) = do - is' <- reduceMergeTree anyOp allOp leafOp is - case is' of - [i2] -> noInferred i2 >> return i2 - is3 -> compileErrorM $ "Could not reconcile guesses for " ++ show i ++ ": " ++ show is3 - -- Skip filtering out inferred types here, in case the guess can be replaced - -- with something better that doesn't have an inferred type. - leafOp i = return [i] - anyOp = mergeObjects anyCheck . sortBy lessGeneral - allOp = mergeObjects allCheck . sortBy moreGeneral - noInferred (InferredTypeGuess n t _) = - when (hasInferredParams t) $ - compileErrorM $ "Guess " ++ show t ++ " for parameter " ++ show n ++ " contains inferred types" - lessGeneral x y = itgVariance y `compare` itgVariance x - moreGeneral x y = itgVariance x `compare` itgVariance y - anyCheck ga@(InferredTypeGuess _ g1 v1) (InferredTypeGuess _ g2 _) = do - noInferred ga - -- Find the least-general guess: If g1 can be replaced with g2, prefer g1. - checkGeneralMatch r f v1 g1 g2 - allCheck ga@(InferredTypeGuess _ g1 _) (InferredTypeGuess _ g2 v2) = do - noInferred ga - -- Find the most-general guess: If g2 can be replaced with g1, prefer g1. - checkGeneralMatch r f v2 g2 g1 + (GuessUnion gs) <- reduceMergeTree anyOp allOp leafOp is >>= filterGuesses i + t <- takeBest i gs + return (InferredTypeGuess i t Invariant) + leafOp (InferredTypeGuess _ t Covariant) = return $ GuessUnion [GuessRange t maxBound] + leafOp (InferredTypeGuess _ t Contravariant) = return $ GuessUnion [GuessRange minBound t] + leafOp (InferredTypeGuess _ t _) = return $ GuessUnion [GuessRange t t] + anyOp = fmap (GuessUnion . concat . map guGuesses) . collectAllM + allOp = collectAllM >=> prodAll + prodAll [] = return $ GuessUnion [] + prodAll [GuessUnion gs] = return $ GuessUnion $ nub gs + prodAll ((GuessUnion g1):(GuessUnion g2):gs) = do + g <- g1 `guessProd` g2 + prodAll (GuessUnion g:gs) + guessProd xs ys = fmap concat $ collectAllM $ do + x <- nub xs + y <- nub ys + [x `guessIntersect` y] + guessIntersect (GuessRange loX hiX) (GuessRange loY hiY) = do + q1 <- loX `convertsTo` hiY + q2 <- loY `convertsTo` hiX + if q1 && q2 + then do + loZ <- tryMerge Covariant loX loY + hiZ <- tryMerge Contravariant hiX hiY + return [GuessRange loZ hiZ] + else return [] + convertsTo t1 t2 = isCompileSuccessM $ checkGeneralMatch r f Covariant t1 t2 + tryMerge v t1 t2 = collectFirstM [ + checkGeneralMatch r f v t1 t2 >> return t2, + checkGeneralMatch r f v t2 t1 >> return t1, + return $ case v of + Covariant -> mergeAny [t1,t2] + Contravariant -> mergeAll [t1,t2] + _ -> undefined + ] + simplifyUnion [] = return [] + simplifyUnion (g:gs) = do + ga <- tryRangeUnion [] g gs + case ga of + Just gs2 -> simplifyUnion gs2 + Nothing -> do + gs2 <- simplifyUnion gs + return (g:gs2) + -- Returns Just a new list if there was a merge, and Nothing otherwise. + tryRangeUnion ms g1@(GuessRange loX hiX) (g2@(GuessRange loY hiY):gs) = do + l1 <- loX `convertsTo` loY + l2 <- loY `convertsTo` loX + let loZ = case (l1,l2) of + (True,_) -> Just loX + (_,True) -> Just loY + _ -> Nothing + h1 <- hiX `convertsTo` hiY + h2 <- hiY `convertsTo` hiX + let hiZ = case (h1,h2) of + (True,_) -> Just hiY + (_,True) -> Just hiX + _ -> Nothing + case (loZ,hiZ) of + (Just lo,Just hi) -> return $ Just $ ms ++ [GuessRange lo hi] ++ gs + _ -> tryRangeUnion (ms ++ [g2]) g1 gs + tryRangeUnion _ _ _ = return Nothing + takeBest i [g@(GuessRange lo hi)] = do + same <- hi `convertsTo` lo + let openHi = hi == maxBound + let openLo = lo == minBound + case (same,openHi,openLo) of + (True,_,_) -> return lo + (_,True,False) -> return lo + (_,False,True) -> return hi + _ -> compileErrorM (show g) do + let checkLo = checkSubFilters i lo + let checkHi = checkSubFilters i hi + pLo <- isCompileErrorM checkLo + pHi <- isCompileErrorM checkHi + case (pLo,pHi) of + (True,True) -> collectAllM_ [checkLo,checkHi] >> compileErrorM "" + (True,_) -> return $ GuessRange hi hi + (_,True) -> return $ GuessRange lo lo + _ -> return $ GuessRange lo hi + (loP,hiP) -> do + when (not loP) $ checkSubFilters i lo + when (not hiP) $ checkSubFilters i hi + return g + checkSubFilters i t = ("In guess " ++ show t ++ " for param " ++ show i) ??> do + let ps' = Map.insert i t ps + fs <- ff `filterLookup` i + fs' <- mapErrorsM (uncheckedSubFilter (getValueForParam ps'))fs + validateAssignment r f t fs' diff --git a/src/Types/TypeInstance.hs b/src/Types/TypeInstance.hs --- a/src/Types/TypeInstance.hs +++ b/src/Types/TypeInstance.hs @@ -42,21 +42,24 @@ ValueType(..), checkDefinesMatch, checkGeneralMatch, + checkValueAssignment, checkValueTypeMatch, - checkValueTypeMatch_, + filterLookup, fixTypeParams, + flipFilter, getValueForParam, hasInferredParams, - isBuiltinCategory, isDefinesFilter, isRequiresFilter, isWeakValue, + mapTypeGuesses, noInferredTypes, requiredParam, requiredSingleton, uncheckedSubFilter, uncheckedSubFilters, uncheckedSubInstance, + uncheckedSubSingle, uncheckedSubValueType, unfixTypeParams, validateAssignment, @@ -68,7 +71,7 @@ validateTypeInstance, ) where -import Control.Monad ((>=>),when) +import Control.Monad (when) import Data.List (intercalate) import qualified Data.Map as Map @@ -83,11 +86,11 @@ 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) ++ "]" + show = reduceMergeTree showAny showAll show where + showAny [] = "all" + showAny ts = "[" ++ intercalate "|" ts ++ "]" + showAll [] = "any" + showAll ts = "[" ++ intercalate "&" ts ++ "]" data StorageType = WeakValue | @@ -111,10 +114,10 @@ isWeakValue = (== WeakValue) . vtRequired requiredSingleton :: CategoryName -> ValueType -requiredSingleton n = ValueType RequiredValue $ SingleType $ JustTypeInstance $ TypeInstance n (Positional []) +requiredSingleton n = ValueType RequiredValue $ singleType $ JustTypeInstance $ TypeInstance n (Positional []) requiredParam :: ParamName -> ValueType -requiredParam n = ValueType RequiredValue $ SingleType $ JustParamName False n +requiredParam n = ValueType RequiredValue $ singleType $ JustParamName False n data CategoryName = CategoryName { @@ -144,9 +147,6 @@ instance Ord CategoryName where c1 <= c2 = show c1 <= show c2 -isBuiltinCategory :: CategoryName -> Bool -isBuiltinCategory _ = False - newtype ParamName = ParamName { pnName :: String @@ -215,10 +215,16 @@ FilterAllows deriving (Eq,Ord) +flipFilter :: FilterDirection -> FilterDirection +flipFilter FilterRequires = FilterAllows +flipFilter FilterAllows = FilterRequires + data TypeFilter = TypeFilter { tfDirection :: FilterDirection, - tfType :: TypeInstanceOrParam + -- NOTE: This is GeneralInstance instead of TypeInstanceOrParam so that + -- param substitution can be done safely. + tfType :: GeneralInstance } | DefinesFilter { dfType :: DefinesInstance @@ -246,12 +252,9 @@ viewTypeFilter n f = show n ++ " " ++ show f hasInferredParams :: GeneralInstance -> Bool -hasInferredParams (TypeMerge _ ts) = - any hasInferredParams ts -hasInferredParams (SingleType (JustTypeInstance (TypeInstance _ (Positional ts)))) = - any hasInferredParams ts -hasInferredParams (SingleType (JustInferredType _)) = True -hasInferredParams _ = False +hasInferredParams = reduceMergeTree mergeAny mergeAny checkSingle where + checkSingle (JustInferredType _) = True + checkSingle _ = False type InstanceParams = Positional GeneralInstance type InstanceVariances = Positional Variance @@ -263,22 +266,22 @@ class TypeResolver r where -- Performs parameter substitution for refines. - trRefines :: (MergeableM m, CompileErrorM m) => + trRefines :: CompileErrorM m => r -> TypeInstance -> CategoryName -> m InstanceParams -- Performs parameter substitution for defines. - trDefines :: (MergeableM m, CompileErrorM m) => + trDefines :: CompileErrorM m => r -> TypeInstance -> CategoryName -> m InstanceParams -- Get the parameter variances for the category. - trVariance :: (MergeableM m, CompileErrorM m) => + trVariance :: CompileErrorM m => r -> CategoryName -> m InstanceVariances -- Gets filters for the assigned parameters. - trTypeFilters :: (MergeableM m, CompileErrorM m) => + trTypeFilters :: CompileErrorM m => r -> TypeInstance -> m InstanceFilters -- Gets filters for the assigned parameters. - trDefinesFilters :: (MergeableM m, CompileErrorM m) => + trDefinesFilters :: CompileErrorM m => r -> DefinesInstance -> m InstanceFilters -- Returns True if the type is concrete. - trConcrete :: (MergeableM m, CompileErrorM m) => + trConcrete :: CompileErrorM m => r -> CategoryName -> m Bool data AnyTypeResolver = forall r. TypeResolver r => AnyTypeResolver r @@ -291,13 +294,13 @@ trDefinesFilters (AnyTypeResolver r) = trDefinesFilters r trConcrete (AnyTypeResolver r) = trConcrete r -filterLookup :: (CompileErrorM m) => +filterLookup :: CompileErrorM m => ParamFilters -> ParamName -> m [TypeFilter] filterLookup ps n = resolve $ n `Map.lookup` ps where resolve (Just x) = return x resolve _ = compileErrorM $ "Param " ++ show n ++ " not found" -getValueForParam :: (CompileErrorM m) => +getValueForParam :: CompileErrorM m => ParamValues -> ParamName -> m GeneralInstance getValueForParam pa n = case n `Map.lookup` pa of @@ -311,54 +314,69 @@ unfixTypeParams = setParamsFixed False setParamsFixed :: Bool -> GeneralInstance -> GeneralInstance -setParamsFixed f (TypeMerge m ts) = TypeMerge m $ map (setParamsFixed f) ts -setParamsFixed f (SingleType (JustTypeInstance (TypeInstance t ts))) = - SingleType $ JustTypeInstance $ TypeInstance t $ fmap (setParamsFixed f) ts -setParamsFixed f (SingleType (JustParamName _ n2)) = - SingleType $ JustParamName f n2 -setParamsFixed _ t = t +setParamsFixed f = mapGeneralType set where + set (JustTypeInstance (TypeInstance t ts)) = + JustTypeInstance $ TypeInstance t $ fmap (setParamsFixed f) ts + set (JustParamName _ n2) = JustParamName f n2 + set t = t -noInferredTypes :: (MergeableM m, CompileErrorM m) => m (MergeTree InferredTypeGuess) -> m () -noInferredTypes = id >=> reduceMergeTree return return message where - message i = compileErrorM $ "Type guess " ++ show i ++ " not allowed here" +mapTypeGuesses :: MergeTree InferredTypeGuess -> Map.Map ParamName (MergeTree InferredTypeGuess) +mapTypeGuesses = reduceMergeTree mergeAny mergeAll leafToMap where + leafToMap i = Map.fromList [(itgParam i,mergeLeaf i)] -checkValueTypeMatch_ :: (MergeableM m, CompileErrorM m, TypeResolver r) => +noInferredTypes :: CompileErrorM m => m (MergeTree InferredTypeGuess) -> m () +noInferredTypes g = do + g' <- g + let gm = mapTypeGuesses g' + "Type inference is not allowed here" !!> (mapErrorsM_ format $ Map.elems gm) where + format = compileErrorM . reduceMergeTree showAny showAll show + showAny gs = "Any of [ " ++ intercalate ", " gs ++ " ]" + showAll gs = "All of [ " ++ intercalate ", " gs ++ " ]" + +checkValueAssignment :: (CompileErrorM m, TypeResolver r) => r -> ParamFilters -> ValueType -> ValueType -> m () -checkValueTypeMatch_ r f t1 t2 = noInferredTypes $ checkValueTypeMatch r f t1 t2 +checkValueAssignment r f t1 t2 = noInferredTypes $ checkValueTypeMatch r f Covariant t1 t2 -checkValueTypeMatch :: (MergeableM m, CompileErrorM m, TypeResolver r) => - r -> ParamFilters -> ValueType -> ValueType -> m (MergeTree InferredTypeGuess) -checkValueTypeMatch r f ts1@(ValueType r1 t1) ts2@(ValueType r2 t2) - | r1 < r2 = - compileErrorM $ "Cannot convert " ++ show ts1 ++ " to " ++ show ts2 - | otherwise = checkGeneralMatch r f Covariant t1 t2 + r -> ParamFilters -> Variance -> ValueType -> ValueType -> m (MergeTree InferredTypeGuess) +checkValueTypeMatch r f v ts1@(ValueType r1 t1) ts2@(ValueType r2 t2) = result " ++ show ts2 + | v == Contravariant = "Cannot convert " ++ show ts1 ++ " <- " ++ show ts2 + | otherwise = "Cannot convert " ++ show ts1 ++ " <-> " ++ show ts2 + storageDir + | r1 > r2 = Covariant + | r1 < r2 = Contravariant + | otherwise = Invariant + result = do + when (not $ storageDir `allowsVariance` v) $ compileErrorM "Incompatible storage modifiers" + checkGeneralMatch r f v t1 t2 -checkGeneralMatch :: (MergeableM m, CompileErrorM m, TypeResolver r) => +checkGeneralMatch :: (CompileErrorM m, TypeResolver r) => r -> ParamFilters -> Variance -> GeneralInstance -> GeneralInstance -> m (MergeTree InferredTypeGuess) -checkGeneralMatch _ _ _ (SingleType (JustInferredType p1)) _ = - compileErrorM $ "Inferred parameter " ++ show p1 ++ " is not allowed on the left" -checkGeneralMatch _ _ v t1 (SingleType (JustInferredType p2)) = - return $ mergeLeaf $ InferredTypeGuess p2 t1 v -checkGeneralMatch r f Invariant ts1 ts2 = - -- This ensures that any and all behave as expected in Invariant positions. - mergeAllM [checkGeneralMatch r f Covariant ts1 ts2, - checkGeneralMatch r f Contravariant ts1 ts2] -checkGeneralMatch r f Contravariant ts1 ts2 = - -- NOTE: ts1 and ts2 can't be swapped in checkSingleMatch due to type - -- inference; however, checkGeneralType is sensitive to which side the empty - -- union or intersection is on. - checkGeneralType (flip $ checkSingleMatch r f Contravariant) ts2 ts1 -checkGeneralMatch r f v ts1 ts2 = checkGeneralType (checkSingleMatch r f v) ts1 ts2 +checkGeneralMatch r f v t1 t2 = collectFirstM [matchInferredRight,bothSingle,matchNormal v] where + matchNormal Invariant = + mergeAllM [matchNormal Contravariant,matchNormal Covariant] + matchNormal Contravariant = + pairMergeTree mergeAnyM mergeAllM (checkSingleMatch r f Contravariant) (dualGeneralType t1) (dualGeneralType t2) + matchNormal Covariant = + pairMergeTree mergeAnyM mergeAllM (checkSingleMatch r f Covariant) t1 t2 + matchInferredRight = matchOnlyLeaf t2 >>= inferFrom + inferFrom (JustInferredType p) = return $ mergeLeaf $ InferredTypeGuess p t1 v + inferFrom _ = compileErrorM "" + bothSingle = do + t1' <- matchOnlyLeaf t1 + t2' <- matchOnlyLeaf t2 + checkSingleMatch r f v t1' t2' -checkSingleMatch :: (MergeableM m, CompileErrorM m, TypeResolver r) => +checkSingleMatch :: (CompileErrorM m, TypeResolver r) => r -> ParamFilters -> Variance -> TypeInstanceOrParam -> TypeInstanceOrParam -> m (MergeTree InferredTypeGuess) checkSingleMatch _ _ _ (JustInferredType p1) _ = compileErrorM $ "Inferred parameter " ++ show p1 ++ " is not allowed on the left" checkSingleMatch _ _ v t1 (JustInferredType p2) = - return $ mergeLeaf $ InferredTypeGuess p2 (SingleType t1) v + return $ mergeLeaf $ InferredTypeGuess p2 (singleType t1) v checkSingleMatch r f v (JustTypeInstance t1) (JustTypeInstance t2) = checkInstanceToInstance r f v t1 t2 checkSingleMatch r f v (JustParamName _ p1) (JustTypeInstance t2) = @@ -368,79 +386,71 @@ checkSingleMatch r f v (JustParamName _ p1) (JustParamName _ p2) = checkParamToParam r f v p1 p2 -checkInstanceToInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) => +checkInstanceToInstance :: (CompileErrorM m, TypeResolver r) => r -> ParamFilters -> Variance -> TypeInstance -> TypeInstance -> m (MergeTree InferredTypeGuess) -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@(TypeInstance n1 ps1) t2@(TypeInstance n2 ps2) - | n1 == n2 = do - paired <- processPairs alwaysPair ps1 ps2 - let zipped = Positional paired - variance <- fmap (fmap (composeVariance Contravariant)) $ trVariance r n1 - processPairsM (\v2 (p1,p2) -> checkGeneralMatch r f v2 p1 p2) variance zipped - | otherwise = do - ps2' <- trRefines r t2 n1 - checkInstanceToInstance r f Contravariant t1 (TypeInstance n1 ps2') -checkInstanceToInstance r f Covariant t1@(TypeInstance n1 ps1) t2@(TypeInstance n2 ps2) +checkInstanceToInstance r f v t1@(TypeInstance n1 ps1) t2@(TypeInstance n2 ps2) | n1 == n2 = do - paired <- processPairs alwaysPair ps1 ps2 - let zipped = Positional paired - variance <- fmap (fmap (composeVariance Covariant)) $ trVariance r n1 - processPairsM (\v2 (p1,p2) -> checkGeneralMatch r f v2 p1 p2) variance zipped - | otherwise = do + paired <- fmap Positional $ processPairs alwaysPair ps1 ps2 + variance <- fmap (fmap (composeVariance v)) $ trVariance r n1 + processPairsM (\v2 (p1,p2) -> checkGeneralMatch r f v2 p1 p2) variance paired + | v == Covariant = do ps1' <- trRefines r t1 n2 checkInstanceToInstance r f Covariant (TypeInstance n2 ps1') t2 + | v == Contravariant = do + ps2' <- trRefines r t2 n1 + checkInstanceToInstance r f Contravariant t1 (TypeInstance n1 ps2') + | otherwise = compileErrorM $ "Category " ++ show n2 ++ " is required but got " ++ show n2 -checkParamToInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) => +checkParamToInstance :: (CompileErrorM m, TypeResolver r) => r -> ParamFilters -> Variance -> ParamName -> TypeInstance -> m (MergeTree InferredTypeGuess) 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] + mergeAllM [ + checkParamToInstance r f Covariant n1 t2, + checkParamToInstance r f Contravariant n1 t2 + ] checkParamToInstance r f v@Contravariant n1 t2@(TypeInstance _ _) = do cs2 <- fmap (filter isTypeFilter) $ f `filterLookup` n1 - mergeAnyM (map checkConstraintToInstance cs2) x implies T -> x only if T -> F - checkSingleMatch r f v t (JustTypeInstance t2) + checkGeneralMatch r f v t (singleType $ JustTypeInstance t2) checkConstraintToInstance f2 = -- x -> F cannot imply T -> x compileErrorM $ "Constraint " ++ viewTypeFilter n1 f2 ++ " does not imply " ++ show t2 ++ " <- " ++ show n1 checkParamToInstance r f v@Covariant n1 t2@(TypeInstance _ _) = do cs1 <- fmap (filter isTypeFilter) $ f `filterLookup` n1 - mergeAnyM (map checkConstraintToInstance cs1) " ++ show t2 ++ " in " ++ show v ++ " contexts") where checkConstraintToInstance (TypeFilter FilterRequires t) = -- x -> F implies x -> T only if F -> T - checkSingleMatch r f v t (JustTypeInstance t2) + checkGeneralMatch r f v t (singleType $ JustTypeInstance t2) checkConstraintToInstance f2 = -- F -> x cannot imply x -> T -- DefinesInstance cannot be converted to TypeInstance compileErrorM $ "Constraint " ++ viewTypeFilter n1 f2 ++ " does not imply " ++ show n1 ++ " -> " ++ show t2 -checkInstanceToParam :: (MergeableM m, CompileErrorM m, TypeResolver r) => +checkInstanceToParam :: (CompileErrorM m, TypeResolver r) => r -> ParamFilters -> Variance -> TypeInstance -> ParamName -> m (MergeTree InferredTypeGuess) 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] + mergeAllM [ + checkInstanceToParam r f Covariant t1 n2, + checkInstanceToParam r f Contravariant t1 n2 + ] checkInstanceToParam r f v@Contravariant t1@(TypeInstance _ _) n2 = do cs1 <- fmap (filter isTypeFilter) $ f `filterLookup` n2 - mergeAnyM (map checkInstanceToConstraint cs1) F implies x -> T only if F -> T - checkSingleMatch r f v (JustTypeInstance t1) t + checkGeneralMatch r f v (singleType $ JustTypeInstance t1) t checkInstanceToConstraint f2 = -- F -> x cannot imply x -> T -- DefinesInstance cannot be converted to TypeInstance @@ -448,38 +458,40 @@ " does not imply " ++ show n2 ++ " <- " ++ show t1 checkInstanceToParam r f v@Covariant t1@(TypeInstance _ _) n2 = do cs2 <- fmap (filter isTypeFilter) $ f `filterLookup` n2 - mergeAnyM (map checkInstanceToConstraint cs2) " ++ show n2 ++ " in " ++ show v ++ " contexts") where checkInstanceToConstraint (TypeFilter FilterAllows t) = -- F -> x implies T -> x only if T -> F - checkSingleMatch r f v (JustTypeInstance t1) t + checkGeneralMatch r f v (singleType $ JustTypeInstance t1) t checkInstanceToConstraint f2 = -- x -> F cannot imply T -> x compileErrorM $ "Constraint " ++ viewTypeFilter n2 f2 ++ " does not imply " ++ show t1 ++ " -> " ++ show n2 -checkParamToParam :: (MergeableM m, CompileErrorM m, TypeResolver r) => +checkParamToParam :: (CompileErrorM m, TypeResolver r) => r -> ParamFilters -> Variance -> ParamName -> ParamName -> m (MergeTree InferredTypeGuess) 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] + | n1 == n2 = return maxBound + | otherwise = + -- Implicit equality, inferred by n1 <-> n2. + mergeAllM [ + checkParamToParam r f Covariant n1 n2, + checkParamToParam r f Contravariant n1 n2 + ] checkParamToParam r f v n1 n2 - | n1 == n2 = mergeDefaultM + | n1 == n2 = return maxBound | 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 v c1 c2) typeFilters) checkConstraintToConstraint v c1 c2) typeFilters) " ++ show n2) where - selfParam1 = JustParamName False n1 - selfParam2 = JustParamName False n2 + selfParam1 = singleType $ JustParamName False n1 + selfParam2 = singleType $ JustParamName False n2 self1 | v == Covariant = TypeFilter FilterRequires selfParam1 | otherwise = TypeFilter FilterAllows selfParam1 @@ -490,7 +502,7 @@ | t1 == selfParam1 && t2 == selfParam2 = compileErrorM $ "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 + | otherwise = checkGeneralMatch r f Covariant t1 t2 checkConstraintToConstraint Covariant f1 f2 = -- x -> F1, y -> F2 cannot imply x -> y -- F1 -> x, F1 -> y cannot imply x -> y @@ -502,7 +514,7 @@ | t1 == selfParam1 && t2 == selfParam2 = compileErrorM $ "Infinite recursion in " ++ show n1 ++ " <- " ++ show n2 -- x <- F1, F2 <- y implies x <- y only if F1 <- F2 - | otherwise = checkSingleMatch r f Contravariant t1 t2 + | otherwise = checkGeneralMatch r f Contravariant t1 t2 checkConstraintToConstraint Contravariant f1 f2 = -- x <- F1, y <- F2 cannot imply x <- y -- F1 <- x, F1 <- y cannot imply x <- y @@ -512,61 +524,55 @@ show n1 ++ " <- " ++ show n2 checkConstraintToConstraint _ _ _ = undefined -validateGeneralInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) => +validateGeneralInstance :: (CompileErrorM m, TypeResolver r) => r -> ParamFilters -> GeneralInstance -> m () -validateGeneralInstance r f (TypeMerge _ ts) - | length ts == 1 = compileErrorM $ "Unions and intersections must have at least 2 types to avoid ambiguity" - | otherwise = 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) $ - compileErrorM $ "Param " ++ show n ++ " does not exist" -validateGeneralInstance _ _ t = compileErrorM $ "Type " ++ show t ++ " contains unresolved types" +validateGeneralInstance r f = reduceMergeTree collectAllM_ collectAllM_ validateSingle where + validateSingle (JustTypeInstance t) = validateTypeInstance r f t + validateSingle (JustParamName _ n) = when (not $ n `Map.member` f) $ + compileErrorM $ "Param " ++ show n ++ " does not exist" + validateSingle (JustInferredType n) = compileErrorM $ "Inferred param " ++ show n ++ " is not allowed here" -validateTypeInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) => +validateTypeInstance :: (CompileErrorM m, TypeResolver r) => r -> ParamFilters -> TypeInstance -> m () validateTypeInstance r f t@(TypeInstance _ ps) = do fa <- trTypeFilters r t processPairs_ (validateAssignment r f) ps fa - mergeAllM (map (validateGeneralInstance r f) (pValues ps)) +validateDefinesInstance :: (CompileErrorM m, TypeResolver r) => r -> ParamFilters -> DefinesInstance -> m () validateDefinesInstance r f t@(DefinesInstance _ ps) = do fa <- trDefinesFilters r t processPairs_ (validateAssignment r f) ps fa - mergeAllM (map (validateGeneralInstance r f) (pValues ps)) +validateTypeFilter :: (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 +validateTypeFilter r f (TypeFilter _ t) = validateGeneralInstance r f t +validateTypeFilter r f (DefinesFilter t) = validateDefinesInstance r f t -validateAssignment :: (MergeableM m, CompileErrorM m, TypeResolver r) => +validateAssignment :: (CompileErrorM m, TypeResolver r) => r -> ParamFilters -> GeneralInstance -> [TypeFilter] -> m () -validateAssignment r f t fs = mergeAllM (map (checkFilter t) fs) where +validateAssignment r f t fs = mapErrorsM_ checkWithMessage fs where + checkWithMessage f2 = checkFilter t f2 +checkDefinesMatch :: (CompileErrorM m, TypeResolver r) => r -> ParamFilters -> DefinesInstance -> DefinesInstance -> m () checkDefinesMatch r f f2@(DefinesInstance n2 ps2) f1@(DefinesInstance n1 ps1) | n1 == n2 = do @@ -575,64 +581,61 @@ processPairs_ (\v2 (p1,p2) -> checkGeneralMatch r f v2 p1 p2) variance (Positional paired) | otherwise = compileErrorM $ "Constraint " ++ show f1 ++ " does not imply " ++ show f2 -validateInstanceVariance :: (MergeableM m, CompileErrorM m, TypeResolver r) => +validateInstanceVariance :: (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 _ vm v (SingleType (JustParamName _ n)) = - case n `Map.lookup` vm of - Nothing -> compileErrorM $ "Param " ++ show n ++ " is undefined" - (Just v0) -> when (not $ v0 `paramAllowsVariance` v) $ - compileErrorM $ "Param " ++ show n ++ " cannot be " ++ show v -validateInstanceVariance _ _ _ t = compileErrorM $ "Type " ++ show t ++ " contains unresolved types" +validateInstanceVariance r vm v = reduceMergeTree collectAllM_ collectAllM_ validateSingle where + validateSingle (JustTypeInstance (TypeInstance n ps)) = do + vs <- trVariance r n + paired <- processPairs alwaysPair vs ps + mapErrorsM_ (\(v2,p) -> validateInstanceVariance r vm (v `composeVariance` v2) p) paired + validateSingle (JustParamName _ n) = + case n `Map.lookup` vm of + Nothing -> compileErrorM $ "Param " ++ show n ++ " is undefined" + (Just v0) -> when (not $ v0 `allowsVariance` v) $ + compileErrorM $ "Param " ++ show n ++ " cannot be " ++ show v + validateSingle (JustInferredType n) = + compileErrorM $ "Inferred param " ++ show n ++ " is not allowed here" -validateDefinesVariance :: (MergeableM m, CompileErrorM m, TypeResolver r) => +validateDefinesVariance :: (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) + mapErrorsM_ (\(v2,p) -> validateInstanceVariance r vm (v `composeVariance` v2) p) paired -uncheckedSubValueType :: (MergeableM m, CompileErrorM m) => +uncheckedSubValueType :: 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 <- mapErrorsM subAll ts - return (TypeMerge MergeUnion gs) - subAll (TypeMerge MergeIntersect ts) = do - gs <- mapErrorsM subAll ts - return (TypeMerge MergeIntersect gs) - subAll (SingleType t) = subInstance t - subInstance (JustTypeInstance (TypeInstance n (Positional ts))) = do - gs <- mapErrorsM subAll ts - let t2 = SingleType $ JustTypeInstance $ TypeInstance n (Positional gs) - return (t2) - subInstance p@(JustParamName True _) = return $ SingleType p - subInstance (JustParamName _ n) = replace n - subInstance t = compileErrorM $ "Type " ++ show t ++ " contains unresolved types" +uncheckedSubInstance :: CompileErrorM m => (ParamName -> m GeneralInstance) -> + GeneralInstance -> m GeneralInstance +uncheckedSubInstance replace = reduceMergeTree subAny subAll subSingle where + -- NOTE: Don't use mergeAnyM because it will fail if the union is empty. + subAny = fmap mergeAny . sequence + subAll = fmap mergeAll . sequence + subSingle p@(JustParamName True _) = return $ singleType p + subSingle (JustParamName _ n) = replace n + subSingle (JustInferredType n) = replace n + subSingle (JustTypeInstance t) = fmap (singleType . JustTypeInstance) $ uncheckedSubSingle replace t -uncheckedSubFilter :: (MergeableM m, CompileErrorM m) => +uncheckedSubSingle :: CompileErrorM m => (ParamName -> m GeneralInstance) -> + TypeInstance -> m TypeInstance +uncheckedSubSingle replace (TypeInstance n (Positional ts)) = do + ts' <- mapErrorsM (uncheckedSubInstance replace) ts + return $ TypeInstance n (Positional ts') + +uncheckedSubFilter :: CompileErrorM m => (ParamName -> m GeneralInstance) -> TypeFilter -> m TypeFilter uncheckedSubFilter replace (TypeFilter d t) = do - t' <- uncheckedSubInstance replace (SingleType t) - return (TypeFilter d (stType t')) + t' <- uncheckedSubInstance replace t + return (TypeFilter d t') uncheckedSubFilter replace (DefinesFilter (DefinesInstance n ts)) = do ts' <- mapErrorsM (uncheckedSubInstance replace) (pValues ts) return (DefinesFilter (DefinesInstance n (Positional ts'))) -uncheckedSubFilters :: (MergeableM m, CompileErrorM m) => +uncheckedSubFilters :: CompileErrorM m => (ParamName -> m GeneralInstance) -> ParamFilters -> m ParamFilters uncheckedSubFilters replace fa = do fa' <- mapErrorsM subParam $ Map.toList fa diff --git a/src/Types/Variance.hs b/src/Types/Variance.hs --- a/src/Types/Variance.hs +++ b/src/Types/Variance.hs @@ -20,8 +20,8 @@ module Types.Variance ( Variance(..), + allowsVariance, composeVariance, - paramAllowsVariance, ) where @@ -45,10 +45,8 @@ 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 +allowsVariance :: Variance -> Variance -> Bool +Covariant `allowsVariance` Covariant = True +Contravariant `allowsVariance` Contravariant = True +Invariant `allowsVariance` _ = True +_ `allowsVariance` _ = False diff --git a/tests/builtin-types.0rt b/tests/builtin-types.0rt --- a/tests/builtin-types.0rt +++ b/tests/builtin-types.0rt @@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "not true" { - success Test$run() + success Test.run() } define Test { @@ -34,7 +34,7 @@ testcase "reduce Bool" { - success Test$run() + success Test.run() } define Test { @@ -66,7 +66,7 @@ testcase "reduce Char" { - success Test$run() + success Test.run() } define Test { @@ -98,7 +98,7 @@ testcase "reduce Int" { - success Test$run() + success Test.run() } define Test { @@ -130,7 +130,7 @@ testcase "reduce Float" { - success Test$run() + success Test.run() } define Test { @@ -162,7 +162,7 @@ testcase "reduce String" { - success Test$run() + success Test.run() } define Test { @@ -194,7 +194,7 @@ testcase "reduce ReadPosition success" { - success Test$run() + success Test.run() } define Test { @@ -211,7 +211,7 @@ testcase "reduce ReadPosition fail" { - success Test$run() + success Test.run() } define Test { @@ -228,12 +228,12 @@ testcase "String LessThan" { - success Test$run() + success Test.run() } define Test { run () { - if (!("x" `String$lessThan` "y")) { + if (!("x" `String.lessThan` "y")) { fail("Failed") } } @@ -245,12 +245,12 @@ testcase "Bool Equals" { - success Test$run() + success Test.run() } define Test { run () { - if (!(true `Bool$equals` true)) { + if (!(true `Bool.equals` true)) { fail("Failed") } } @@ -262,12 +262,12 @@ testcase "String Equals" { - success Test$run() + success Test.run() } define Test { run () { - if (!("x" `String$equals` "x")) { + if (!("x" `String.equals` "x")) { fail("Failed") } } @@ -279,15 +279,15 @@ testcase "String Builder" { - success Test$run() + success Test.run() } define Test { run () { - Builder builder <- String$builder() - \ Testing$check(builder.build(),"") - \ Testing$check(builder.append("xyz").build(),"xyz") - \ Testing$check(builder.append("123").build(),"xyz123") + Builder builder <- String.builder() + \ Testing.check(builder.build(),"") + \ Testing.check(builder.append("xyz").build(),"xyz") + \ Testing.check(builder.append("123").build(),"xyz123") } } @@ -297,12 +297,12 @@ testcase "Char LessThan" { - success Test$run() + success Test.run() } define Test { run () { - if (!('x' `Char$lessThan` 'y')) { + if (!('x' `Char.lessThan` 'y')) { fail("Failed") } } @@ -314,12 +314,12 @@ testcase "Char Equals" { - success Test$run() + success Test.run() } define Test { run () { - if (!('x' `Char$equals` 'x')) { + if (!('x' `Char.equals` 'x')) { fail("Failed") } } @@ -331,12 +331,12 @@ testcase "Int LessThan" { - success Test$run() + success Test.run() } define Test { run () { - if (!(1 `Int$lessThan` 2)) { + if (!(1 `Int.lessThan` 2)) { fail("Failed") } } @@ -348,12 +348,12 @@ testcase "Int Equals" { - success Test$run() + success Test.run() } define Test { run () { - if (!(1 `Int$equals` 1)) { + if (!(1 `Int.equals` 1)) { fail("Failed") } } @@ -365,12 +365,12 @@ testcase "Float LessThan" { - success Test$run() + success Test.run() } define Test { run () { - if (!(1.0 `Float$lessThan` 2.0)) { + if (!(1.0 `Float.lessThan` 2.0)) { fail("Failed") } } @@ -382,12 +382,12 @@ testcase "Float Equals" { - success Test$run() + success Test.run() } define Test { run () { - if (!(1.0 `Float$equals` 1.0)) { + if (!(1.0 `Float.equals` 1.0)) { fail("Failed") } } @@ -399,7 +399,7 @@ testcase "Bool is shared" { - success Test$run() + success Test.run() } define Test { @@ -419,7 +419,7 @@ testcase "String is shared" { - success Test$run() + success Test.run() } define Test { @@ -438,7 +438,7 @@ testcase "String Builder is not lazy" { - success Test$run() + success Test.run() } define Test { @@ -448,7 +448,7 @@ if (!present(strong(value2))) { fail("Failed") } - Builder builder <- String$builder().append(require(value1)) + Builder builder <- String.builder().append(require(value1)) value1 <- empty if (present(strong(value2))) { fail("Failed") @@ -462,7 +462,7 @@ testcase "Char is not shared" { - success Test$run() + success Test.run() } define Test { @@ -481,7 +481,7 @@ testcase "Int is not shared" { - success Test$run() + success Test.run() } define Test { @@ -500,7 +500,7 @@ testcase "Float is not shared" { - success Test$run() + success Test.run() } define Test { @@ -519,7 +519,7 @@ testcase "String Formatted" { - success Test$run() + success Test.run() } define Test { @@ -537,7 +537,7 @@ testcase "Char Formatted" { - success Test$run() + success Test.run() } define Test { @@ -555,7 +555,7 @@ testcase "Char octal Formatted" { - success Test$run() + success Test.run() } define Test { @@ -573,7 +573,7 @@ testcase "Char hex Formatted" { - success Test$run() + success Test.run() } define Test { @@ -591,7 +591,7 @@ testcase "Int Formatted" { - success Test$run() + success Test.run() } define Test { @@ -609,7 +609,7 @@ testcase "Int hex Formatted" { - success Test$run() + success Test.run() } define Test { @@ -627,7 +627,7 @@ testcase "Float Formatted" { - success Test$run() + success Test.run() } define Test { @@ -645,7 +645,7 @@ testcase "Bool Formatted" { - success Test$run() + success Test.run() } define Test { @@ -663,7 +663,7 @@ testcase "String access" { - success Test$run() + success Test.run() } define Test { @@ -686,7 +686,7 @@ testcase "String access negative" { - crash Test$run() + crash Test.run() require "-10" require "bounds" } @@ -703,7 +703,7 @@ testcase "String access past end" { - crash Test$run() + crash Test.run() require "100" require "bounds" } @@ -720,7 +720,7 @@ testcase "String subsequence" { - success Test$run() + success Test.run() } define Test { @@ -739,7 +739,7 @@ testcase "String empty subsequence at end" { - success Test$run() + success Test.run() } define Test { @@ -758,7 +758,7 @@ testcase "String subsequence past end" { - crash Test$run() + crash Test.run() require "100" require "size" } @@ -775,7 +775,7 @@ testcase "Int max is accurate" { - success Test$run() + success Test.run() } define Test { @@ -793,7 +793,7 @@ testcase "Int min is accurate" { - success Test$run() + success Test.run() } define Test { @@ -811,7 +811,7 @@ testcase "Int unsigned works properly" { - success Test$run() + success Test.run() } define Test { @@ -879,7 +879,7 @@ testcase "Float exponent does not cross whitespace" { - success Test$run() + success Test.run() } concrete E10 { @@ -895,7 +895,7 @@ define Test { run () { Float x <- 1.2345 - E10 y <- E10$create() + E10 y <- E10.create() } } @@ -905,7 +905,7 @@ testcase "String allows null" { - success Test$run() + success Test.run() } define Test { @@ -925,7 +925,7 @@ testcase "Bool conversions" { - success Test$run() + success Test.run() } define Test { @@ -955,7 +955,7 @@ testcase "Char conversions" { - success Test$run() + success Test.run() } define Test { @@ -989,7 +989,7 @@ testcase "Int conversions" { - success Test$run() + success Test.run() } define Test { @@ -1023,7 +1023,7 @@ testcase "Float conversions" { - success Test$run() + success Test.run() } define Test { @@ -1053,7 +1053,7 @@ testcase "String conversions" { - success Test$run() + success Test.run() } define Test { diff --git a/tests/cli-tests.sh b/tests/cli-tests.sh --- a/tests/cli-tests.sh +++ b/tests/cli-tests.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash # ------------------------------------------------------------------------------ # Copyright 2020 Kevin P. Barry @@ -88,6 +88,16 @@ } +test_tests_only3() { + local output=$(do_zeolite -p "$ZEOLITE_PATH" -r tests/tests-only3 -f || true) + if ! echo "$output" | egrep -q 'NotTestsOnly.+\$TestsOnly\$'; then + show_message 'Expected NotTestsOnly definition error from tests/tests-only:' + echo "$output" 1>&2 + return 1 + fi +} + + test_module_only() { local output=$(do_zeolite -p "$ZEOLITE_PATH" -R tests/module-only -f || true) if ! echo "$output" | egrep -q 'Type1 not found'; then @@ -123,6 +133,32 @@ } +test_module_only3() { + local output=$(do_zeolite -p "$ZEOLITE_PATH" -R tests/module-only3 -f || true) + if ! echo "$output" | egrep -q 'Category_Type1\.hpp'; then + show_message 'Expected Type1 visibility error from tests/module-only3:' + echo "$output" 1>&2 + return 1 + fi + if echo "$output" | grep -v 'Writing file' | egrep -q 'Category_Type2\.hpp'; then + show_message 'Unexpected Type2 visibility error from tests/module-only3:' + echo "$output" 1>&2 + return 1 + fi + if echo "$output" | egrep -q 'GetCategory_Type2'; then + show_message 'Unexpected Type2 visibility error from tests/module-only3:' + echo "$output" 1>&2 + return 1 + fi +} + + +test_module_only4() { + do_zeolite -p "$ZEOLITE_PATH" -r tests/module-only4 -f + do_zeolite -p "$ZEOLITE_PATH" -t tests/module-only4 +} + + test_warn_public() { local output=$(do_zeolite -p "$ZEOLITE_PATH" -R tests/warn-public -f) if ! echo "$output" | egrep -q '"internal" .+ public'; then @@ -146,6 +182,22 @@ } +test_show_deps() { + local output=$(do_zeolite -p "$ZEOLITE_PATH" --show-deps tests) + local patterns=( + 'ExprLookup -> Int ".*zeolite/base"' + 'ExprLookup -> String ".*zeolite/base"' + ) + for pattern in "${patterns[@]}"; do + if echo "$output" | egrep -q "$pattern"; then + show_message "Expected \"$pattern\" in --show-deps for tests:" + echo "$output" 1>&2 + return 1 + fi + done +} + + test_fast() { local temp=$(execute mktemp -d) local category='HelloWorld' @@ -159,10 +211,10 @@ define $category { run () { - \ LazyStream\$new() + \ LazyStream.new() .append(\$ExprLookup[MODULE_PATH]\$ + "\n") .append("Hello World\n") - .writeTo(SimpleOutput\$stdout()) + .writeTo(SimpleOutput.stdout()) } } END @@ -238,20 +290,26 @@ ZEOLITE_PATH=$(do_zeolite --get-path | grep '^/') echo 1>&2 local failed=0 - local list=() + local passed_list=() + local failed_list=() for t in "$@"; do show_message "Testing $t >>>" echo 1>&2 if ! "$t"; then failed=1 - list=("${list[@]}" "$t") + failed_list=(${failed_list[@]-} "$t") + else + passed_list=(${passed_list[@]-} "$t") fi echo 1>&2 show_message "<<< Testing $t" echo 1>&2 done + for t in ${passed_list[@]-}; do + show_message "*** $t PASSED ***" + done if (($failed)); then - for t in "${list[@]}"; do + for t in ${failed_list[@]-}; do show_message "*** $t FAILED ***" done return 1 @@ -264,10 +322,14 @@ test_check_defs test_tests_only test_tests_only2 + test_tests_only3 test_module_only test_module_only2 + test_module_only3 + test_module_only4 test_warn_public test_templates + test_show_deps test_fast test_bad_system_include test_global_include diff --git a/tests/conditionals.0rt b/tests/conditionals.0rt --- a/tests/conditionals.0rt +++ b/tests/conditionals.0rt @@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "assign if/elif/else" { - success Test$run() + success Test.run() } @value interface Value {} @@ -43,7 +43,7 @@ testcase "return if/elif/else" { - success Test$run() + success Test.run() } @value interface Value {} @@ -223,7 +223,7 @@ testcase "crash in if" { - crash Test$run() + crash Test.run() require "empty" } @@ -242,7 +242,7 @@ testcase "crash in elif" { - crash Test$run() + crash Test.run() require "empty" } @@ -262,7 +262,7 @@ testcase "multi assign if/elif/else" { - success Test$run() + success Test.run() } @value interface Value {} @@ -378,7 +378,7 @@ testcase "cleanup before return in if" { - success Test$run() + success Test.run() } concrete Value { @@ -413,7 +413,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() Int value1 <- value.call() if (value1 != 2) { fail(value1) diff --git a/tests/expr-lookup.0rt b/tests/expr-lookup.0rt --- a/tests/expr-lookup.0rt +++ b/tests/expr-lookup.0rt @@ -33,7 +33,7 @@ testcase "MODULE_PATH is absolute" { - crash Test$run() + crash Test.run() require "Failed condition: /.+/tests" } @@ -49,13 +49,13 @@ testcase "MODULE_PATH from regular source" { - crash Test$run() + crash Test.run() require "Failed condition: /.+/tests" } define Test { run () { - fail(ExprLookup$modulePath()) + fail(ExprLookup.modulePath()) } } @@ -81,7 +81,7 @@ testcase "macro used inline in expressions" { - crash Test$run() + crash Test.run() require "Failed condition: /.+/tests is the path" } @@ -97,12 +97,12 @@ testcase "constant defined in .zeolite-module" { - success Test$run() + success Test.run() } define Test { run () { - \ Testing$check($ExprLookup[INT_EXPR]$,4) + \ Testing.check($ExprLookup[INT_EXPR]$,4) } } @@ -112,12 +112,12 @@ testcase "constant defined in .zeolite-module from regular source" { - success Test$run() + success Test.run() } define Test { run () { - \ Testing$check(ExprLookup$intExpr(),4) + \ Testing.check(ExprLookup.intExpr(),4) } } @@ -127,14 +127,14 @@ testcase "in context defined in .zeolite-module" { - success Test$run() + success Test.run() } define Test { @category String macroLocalVar <- "hello" run () { - \ Testing$check($ExprLookup[LOCAL_VAR]$,"hello") + \ Testing.check($ExprLookup[LOCAL_VAR]$,"hello") } } @@ -161,12 +161,12 @@ testcase "in context defined in .zeolite-module from regular source" { - success Test$run() + success Test.run() } define Test { run () { - \ Testing$check(ExprLookup$localVar(),99) + \ Testing.check(ExprLookup.localVar(),99) } } @@ -176,12 +176,12 @@ testcase "nested expression defined in .zeolite-module" { - success Test$run() + success Test.run() } define Test { run () { - \ Testing$check($ExprLookup[META_VAR]$,20) + \ Testing.check($ExprLookup[META_VAR]$,20) } } @@ -191,12 +191,12 @@ testcase "function called on expression" { - success Test$run() + success Test.run() } define Test { run () { - \ Testing$check($ExprLookup[INT_EXPR]$.formatted(),"4") + \ Testing.check($ExprLookup[INT_EXPR]$.formatted(),"4") } } @@ -206,7 +206,7 @@ testcase "source context" { - crash Test$run() + crash Test.run() require "tests/expr-lookup\.0rt" } diff --git a/tests/failure.0rt b/tests/failure.0rt --- a/tests/failure.0rt +++ b/tests/failure.0rt @@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "fail builtin" { - crash Test$run() + crash Test.run() require stderr "Failed" } @@ -56,7 +56,7 @@ define Test { run () { - fail(Value$create()) + fail(Value.create()) } } @@ -66,7 +66,7 @@ testcase "require empty" { - crash Test$run() + crash Test.run() require stderr "require.+empty" } diff --git a/tests/filters.0rt b/tests/filters.0rt --- a/tests/filters.0rt +++ b/tests/filters.0rt @@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "external filter not applied in @category" { - success Test$run() + success Test.run() } concrete Value<#x> { @@ -32,10 +32,84 @@ define Test { run () { - \ Value$$something() + \ Value:something() } } concrete Test { @type run () -> () +} + + +testcase "category param bounded on both sides" { + error + require compiler "#x.+bound" +} + +@value interface Type1 {} + +@value interface Type2 {} + +@value interface Value<#x> { + #x requires Type1 + #x allows Type2 +} + + +testcase "implicit bound from reversing another filter" { + error + require compiler "#x.+bound" + require compiler "#x allows #y" +} + +@value interface Type {} + +@value interface Value<#x,#y> { + #x requires Type + #y requires #x +} + + +testcase "defines filter is not an upper bound" { + success empty +} + +@type interface Type1 {} + +@value interface Type2 {} + +@value interface Value<#x> { + #x defines Type1 + #x allows Type2 +} + + +testcase "defines filter is not a lower bound" { + success empty +} + +@type interface Type1 {} + +@value interface Type2 {} + +@value interface Value<#x> { + #x defines Type1 + #x requires Type2 +} + + +testcase "function param bounded on both sides" { + error + require compiler "#x.+bound" +} + +@value interface Type1 {} + +@value interface Type2 {} + +@value interface Value { + call<#x> + #x requires Type1 + #x allows Type2 + () -> () } diff --git a/tests/function-calls.0rt b/tests/function-calls.0rt --- a/tests/function-calls.0rt +++ b/tests/function-calls.0rt @@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "converted call" { - success Test$run() + success Test.run() } @value interface Base { @@ -40,8 +40,8 @@ define Test { run () { - Value value <- Value$create() - \ value.Base$call() + Value value <- Value.create() + \ value.Base.call() } } @@ -74,8 +74,8 @@ define Test { run () { - Value value <- Value$create() - \ value.Base$call() + Value value <- Value.create() + \ value.Base.call() } } @@ -109,7 +109,7 @@ define Test { run () { - [Base|Value] value <- Value$create() + [Base|Value] value <- Value.create() \ value.call() } } @@ -120,7 +120,7 @@ testcase "call from union with conversion" { - success Test$run() + success Test.run() } @value interface Base { @@ -143,8 +143,8 @@ define Test { run () { - [Base|Value] value <- Value$create() - \ value.Base$call() + [Base|Value] value <- Value.create() + \ value.Base.call() } } @@ -154,7 +154,7 @@ testcase "call from intersect" { - success Test$run() + success Test.run() } @value interface Base1 { @@ -180,7 +180,7 @@ define Test { run () { - [Base1&Base2] value <- Value$create() + [Base1&Base2] value <- Value.create() \ value.call() } } @@ -191,7 +191,7 @@ testcase "call from intersect with conversion" { - success Test$run() + success Test.run() } @value interface Base1 { @@ -217,8 +217,8 @@ define Test { run () { - [Base1&Base2] value <- Value$create() - \ value.Base1$call() + [Base1&Base2] value <- Value.create() + \ value.Base1.call() } } @@ -228,7 +228,7 @@ testcase "call from intersect with conversion" { - success Test$run() + success Test.run() } @value interface Base1 { @@ -254,8 +254,8 @@ define Test { run () { - [Base1&Base2] value <- Value$create() - \ value.Base1$call() + [Base1&Base2] value <- Value.create() + \ value.Base1.call() } } @@ -265,7 +265,7 @@ testcase "call from param type" { - success Test$run() + success Test.run() } @type interface Base { @@ -285,7 +285,7 @@ #x defines Base () -> () check () { - \ #x$call() + \ #x.call() } run () { @@ -311,7 +311,7 @@ @type check<#x> () -> () check () { - \ #x$call() + \ #x.call() } run () {} @@ -323,7 +323,7 @@ testcase "call from param value" { - success Test$run() + success Test.run() } @value interface Base { @@ -353,7 +353,7 @@ } run () { - Value value <- Value$create() + Value value <- Value.create() \ check(value) } } @@ -388,7 +388,7 @@ testcase "convert arg" { - success Test$run() + success Test.run() } @value interface Base { @@ -416,7 +416,7 @@ } run () { - \ convert(Value$create()).call() + \ convert(Value.create()).call() } } @@ -471,7 +471,7 @@ define Test { run () { - \ Call$call>() + \ Call.call>() } } diff --git a/tests/function-merging.0rt b/tests/function-merging.0rt --- a/tests/function-merging.0rt +++ b/tests/function-merging.0rt @@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "internal merge" { - success Test$run() + success Test.run() } @value interface Interface { @@ -42,7 +42,7 @@ define Test { run () { - \ Value$create().call().call() + \ Value.create().call().call() } } @@ -89,7 +89,7 @@ testcase "external merge" { - success Test$run() + success Test.run() } @value interface Interface { @@ -114,7 +114,7 @@ define Test { run () { - \ Value$create().call().call() + \ Value.create().call().call() } } diff --git a/tests/helpers.0rx b/tests/helpers.0rx --- a/tests/helpers.0rx +++ b/tests/helpers.0rx @@ -20,7 +20,7 @@ define Testing { check (x,y) { - if (!#x$equals(x,y)) { + if (!#x.equals(x,y)) { fail(x) } } @@ -39,7 +39,7 @@ #x defines LessThan<#x> (#x,#x) -> (Bool) lessEquals (x,y) { - // Using !#x$lessThan(y,x) wouldn't account for NaNs. - return #x$lessThan(x,y) || #x$equals(x,y) + // Using !#x.lessThan(y,x) wouldn't account for NaNs. + return #x.lessThan(x,y) || #x.equals(x,y) } } diff --git a/tests/inference.0rt b/tests/inference.0rt --- a/tests/inference.0rt +++ b/tests/inference.0rt @@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "simple inference" { - success Test$run() + success Test.run() } define Test { @@ -38,6 +38,7 @@ testcase "inference mismatch" { error + require "get" require "String" require "Int" } @@ -59,7 +60,7 @@ testcase "nested inference" { - success Test$run() + success Test.run() } concrete Type<#x> { @@ -74,7 +75,7 @@ define Test { run () { - Type value <- get(Type$create()) + Type value <- get(Type.create()) } @type get<#x> (Type<#x>) -> (Type<#x>) @@ -89,12 +90,12 @@ testcase "simple inference with qualification" { - success Test$run() + success Test.run() } define Test { run () { - Int value <- Test$get(10) + Int value <- Test.get(10) } @type get<#x> (#x) -> (#x) @@ -110,13 +111,14 @@ testcase "inference mismatch with qualification" { error + require "get" require "String" require "Int" } define Test { run () { - String value <- Test$get(10) + String value <- Test.get(10) } @type get<#x> (#x) -> (#x) @@ -131,7 +133,7 @@ testcase "nested inference with qualification" { - success Test$run() + success Test.run() } concrete Type<#x> { @@ -146,7 +148,7 @@ define Test { run () { - Type value <- Test$get(Type$create()) + Type value <- Test.get(Type.create()) } @type get<#x> (Type<#x>) -> (Type<#x>) @@ -162,8 +164,8 @@ testcase "inference conflict" { error - require "String" - require "Int" + require "get" + require "#x" } concrete Type<#x> { @@ -178,7 +180,7 @@ define Test { run () { - Type value <- get(Type$create(),"bad") + Type value <- get(Type.create(),"bad") } @type get<#x> (Type<#x>,#x) -> (Type<#x>) @@ -192,18 +194,16 @@ } -testcase "inference from filter" { +testcase "elimination by filter" { error - require "#x.+get.+Formatted" - require "String" - require "value2" - exclude "value1" + require "get" + require "#x" + require "Formatted.+String" } define Test { run () { - Formatted value1 <- get("value") - String value2 <- get("value") + \ get("value") } @type get<#x> @@ -219,18 +219,16 @@ } -testcase "inference from filter without param" { +testcase "elimination by filter without param" { error - require "#x.+get.+Formatted" - require "String" - require "value2" - exclude "value1" + require "get" + require "#x" + require "Formatted.+String" } define Test { run () { - Formatted value1 <- get("value") - String value2 <- get("value") + \ get("value") } @type get<#y,#x> @@ -246,9 +244,12 @@ } -testcase "inference from filter including param" { +testcase "elimination by filter including param" { error - require "#x.+get.+Type" + require "get" + require "#x" + require "String.+Type" + require "Type.+String" } concrete Type<#x> { @@ -263,7 +264,7 @@ define Test { run () { - Type value2 <- get(Type$create()) + \ get(Type.create()) } @type get<#x> @@ -280,7 +281,7 @@ testcase "clashing param filter in the same scope" { - success Test$run() + success Test.run() } define Test { @@ -299,6 +300,42 @@ get2 (x) { return x } +} + +concrete Test { + @type run () -> () +} + + +testcase "mutually dependent inferences" { + error + require "get" + require "#x.+Int" + require "#y.+String" +} + +concrete Type<#x> { + @type create () -> (Type<#x>) +} + +define Type { + create () { + return Type<#x>{ } + } +} + +define Test { + run () { + Type x <- Type.create() + Type y <- Type.create() + \ get(x,y) + } + + @type get<#x,#y> + #x requires Type<#y> + #y requires Type<#x> + (#x,#y) -> () + get (_,_) {} } concrete Test { diff --git a/tests/infix-functions.0rt b/tests/infix-functions.0rt --- a/tests/infix-functions.0rt +++ b/tests/infix-functions.0rt @@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "category infix" { - success Test$run() + success Test.run() } define Test { @@ -27,7 +27,7 @@ } run () { - Int value <- 1 `Test$$add` 2 + Int value <- 1 `Test:add` 2 if (value != 3) { fail(value) } @@ -40,7 +40,7 @@ testcase "type infix" { - success Test$run() + success Test.run() } define Test { @@ -50,7 +50,7 @@ } run () { - Int value <- 1 `Test$add` 2 + Int value <- 1 `Test.add` 2 if (value != 3) { fail(value) } @@ -63,7 +63,7 @@ testcase "value infix" { - success Test$run() + success Test.run() } concrete Arithmetic { @@ -83,7 +83,7 @@ define Test { run () { - Int value <- 1 `Arithmetic$create().add` 2 + Int value <- 1 `Arithmetic.create().add` 2 if (value != 3) { fail(value) } @@ -96,7 +96,7 @@ testcase "unqualified infix" { - success Test$run() + success Test.run() } define Test { @@ -119,7 +119,7 @@ testcase "infix function comes after arithmetic" { - success Test$run() + success Test.run() } define Test { @@ -142,7 +142,7 @@ testcase "infix function comes before comparison" { - success Test$run() + success Test.run() } define Test { diff --git a/tests/infix-operations.0rt b/tests/infix-operations.0rt --- a/tests/infix-operations.0rt +++ b/tests/infix-operations.0rt @@ -17,12 +17,12 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "Int arithmetic with precedence" { - success Test$run() + success Test.run() } define Test { run () { - \ Testing$check(\x10 + 1 * 2 - 8 / 2 - 3 % 2,13) + \ Testing.check(\x10 + 1 * 2 - 8 / 2 - 3 % 2,13) } } @@ -32,16 +32,16 @@ testcase "Int arithmetic" { - success Test$run() + success Test.run() } define Test { run () { - \ Testing$check(8 + 2,10) - \ Testing$check(8 - 2,6) - \ Testing$check(8 * 2,16) - \ Testing$check(8 / 2,4) - \ Testing$check(8 % 2,0) + \ Testing.check(8 + 2,10) + \ Testing.check(8 - 2,6) + \ Testing.check(8 * 2,16) + \ Testing.check(8 / 2,4) + \ Testing.check(8 % 2,0) } } @@ -51,16 +51,16 @@ testcase "Int bitwise" { - success Test$run() + success Test.run() } define Test { run () { - \ Testing$check(1 << 2,4) - \ Testing$check(7 >> 1,3) - \ Testing$check(7 ^ 2 ,5) - \ Testing$check(7 & ~2,5) - \ Testing$check(5 | 2 ,7) + \ Testing.check(1 << 2,4) + \ Testing.check(7 >> 1,3) + \ Testing.check(7 ^ 2 ,5) + \ Testing.check(7 & ~2,5) + \ Testing.check(5 | 2 ,7) } } @@ -70,12 +70,12 @@ testcase "Int bitwise with precedence" { - success Test$run() + success Test.run() } define Test { run () { - \ Testing$check(1 << 4 | 7 >> 1 & ~2,17) + \ Testing.check(1 << 4 | 7 >> 1 & ~2,17) } } @@ -85,12 +85,12 @@ testcase "same operators applied left to right" { - success Test$run() + success Test.run() } define Test { run () { - \ Testing$check(2 - 1 - 1,0) + \ Testing.check(2 - 1 - 1,0) } } @@ -132,12 +132,12 @@ testcase "String arithmetic" { - success Test$run() + success Test.run() } define Test { run () { - \ Testing$check("x" + "y" + "z","xyz") + \ Testing.check("x" + "y" + "z","xyz") } } @@ -147,12 +147,12 @@ testcase "Float arithmetic with precedence" { - success Test$run() + success Test.run() } define Test { run () { - \ Testing$check(16.0 + 1.0 * 2.0 - 8.0 / 2.0 - 3.0 / 3.0,13.0) + \ Testing.check(16.0 + 1.0 * 2.0 - 8.0 / 2.0 - 3.0 / 3.0,13.0) } } @@ -162,12 +162,12 @@ testcase "Char minus" { - success Test$run() + success Test.run() } define Test { run () { - \ Testing$check('z' - 'a',25) + \ Testing.check('z' - 'a',25) } } @@ -177,7 +177,7 @@ testcase "Bool comparison" { - success Test$run() + success Test.run() } define Test { @@ -194,7 +194,7 @@ testcase "Int comparison" { - success Test$run() + success Test.run() } define Test { @@ -214,7 +214,7 @@ testcase "Float comparison" { - success Test$run() + success Test.run() } define Test { @@ -234,7 +234,7 @@ testcase "String comparison" { - success Test$run() + success Test.run() } define Test { @@ -254,7 +254,7 @@ testcase "Char comparison" { - success Test$run() + success Test.run() } define Test { @@ -274,7 +274,7 @@ testcase "Bool logic with precedence" { - success Test$run() + success Test.run() } define Test { @@ -325,7 +325,7 @@ testcase "String plus with comparison" { - success Test$run() + success Test.run() } define Test { @@ -342,7 +342,7 @@ testcase "Char minus with comparison" { - success Test$run() + success Test.run() } define Test { @@ -359,7 +359,7 @@ testcase "Int arithmetic with comparison" { - success Test$run() + success Test.run() } define Test { @@ -376,7 +376,7 @@ testcase "Float arithmetic with comparison" { - success Test$run() + success Test.run() } define Test { @@ -409,7 +409,7 @@ testcase "arithmetic, comparison, logic" { - success Test$run() + success Test.run() } define Test { diff --git a/tests/internal-inheritance.0rt b/tests/internal-inheritance.0rt --- a/tests/internal-inheritance.0rt +++ b/tests/internal-inheritance.0rt @@ -32,7 +32,7 @@ testcase "internal refine is private" { - success Test$run() + success Test.run() } concrete Value { @@ -58,7 +58,7 @@ define Test { run () { - String value <- Value$create().get().formatted() + String value <- Value.create().get().formatted() if (value != "Value") { fail(value) } @@ -95,7 +95,7 @@ define Test { run () { - Formatted value <- Value$create() + Formatted value <- Value.create() } } @@ -105,7 +105,7 @@ testcase "internal define is private" { - success Test$run() + success Test.run() } concrete Compare<#x> { @@ -116,7 +116,7 @@ define Compare { compare (x,y) { - return #x$equals(x,y) + return #x.equals(x,y) } } @@ -139,7 +139,7 @@ } compare (x,y) { - return Compare$compare(x,y) + return Compare.compare(x,y) } @value get () -> (Int) @@ -150,9 +150,9 @@ define Test { run () { - Value value1 <- Value$create(1) - Value value2 <- Value$create(2) - if (Value$compare(value1,value2)) { + Value value1 <- Value.create(1) + Value value2 <- Value.create(2) + if (Value.compare(value1,value2)) { fail("Failed") } } @@ -178,7 +178,7 @@ define Compare { compare (x,y) { - return #x$equals(x,y) + return #x.equals(x,y) } } @@ -207,9 +207,9 @@ define Test { run () { - Value value1 <- Value$create(1) - Value value2 <- Value$create(2) - if (Compare$compare(value1,value2)) { + Value value1 <- Value.create(1) + Value value2 <- Value.create(2) + if (Compare.compare(value1,value2)) { fail("Failed") } } diff --git a/tests/internal-params.0rt b/tests/internal-params.0rt --- a/tests/internal-params.0rt +++ b/tests/internal-params.0rt @@ -42,7 +42,7 @@ testcase "internal filter not applied in @type" { - success Test$run() + success Test.run() } concrete Value { @@ -59,7 +59,7 @@ define Test { run () { - \ Value$something() + \ Value.something() } } @@ -69,7 +69,7 @@ testcase "internal filter not applied in @category" { - success Test$run() + success Test.run() } concrete Value { @@ -86,7 +86,7 @@ define Test { run () { - \ Value$$something() + \ Value:something() } } @@ -96,7 +96,7 @@ testcase "internal params" { - success Test$run() + success Test.run() } concrete Value { @@ -117,7 +117,7 @@ define Test { run () { - \ Value$create() + \ Value.create() } } @@ -127,7 +127,7 @@ testcase "internal params with filters" { - success Test$run() + success Test.run() } @value interface Get<|#x> { @@ -204,7 +204,7 @@ testcase "internal params with values" { - success Test$run() + success Test.run() } concrete Value { @@ -232,7 +232,7 @@ testcase "value depends on internal param" { - success Test$run() + success Test.run() } concrete Type<#y> { @@ -262,7 +262,7 @@ define Test { run () { - \ Value$create(Type$create()) + \ Value.create(Type.create()) } } @@ -305,7 +305,7 @@ define Test { run () { - \ Value$create(Type$create()) + \ Value.create(Type.create()) } } @@ -380,7 +380,7 @@ testcase "internal param no clash with category" { - success Test$run() + success Test.run() } concrete Value { @@ -405,7 +405,7 @@ testcase "reduce internal param success" { - success Test$run() + success Test.run() } concrete Value { @@ -427,7 +427,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() if (!value.check("")) { fail("Failed") } @@ -440,7 +440,7 @@ testcase "reduce internal param fail" { - success Test$run() + success Test.run() } concrete Value { @@ -462,7 +462,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() if (value.check(value)) { fail("Failed") } diff --git a/tests/member-init.0rt b/tests/member-init.0rt --- a/tests/member-init.0rt +++ b/tests/member-init.0rt @@ -33,7 +33,7 @@ testcase "@category member from @type" { - success Test$run() + success Test.run() } define Test { @@ -53,7 +53,7 @@ testcase "@category member from @value" { - success Test$run() + success Test.run() } define Test { @@ -94,7 +94,7 @@ testcase "@category member refers to @category member" { - success Test$run() + success Test.run() } define Test { @@ -107,7 +107,7 @@ } run () { - \ Testing$check(get(),2) + \ Testing.check(get(),2) } } @@ -117,7 +117,7 @@ testcase "@category member is lazy" { - success Test$run() + success Test.run() } concrete Util { @@ -131,7 +131,7 @@ } define Test { - @category Bool value <- Util$doNotUse() + @category Bool value <- Util.doNotUse() run () {} } @@ -142,7 +142,7 @@ testcase "@category member init when read" { - crash Test$run() + crash Test.run() require "do not use" } @@ -157,7 +157,7 @@ } define Test { - @category Bool value <- Util$doNotUse() + @category Bool value <- Util.doNotUse() run () { Bool value2 <- value @@ -170,7 +170,7 @@ testcase "@category member init when assigned" { - crash Test$run() + crash Test.run() require "do not use" } @@ -185,7 +185,7 @@ } define Test { - @category Bool value <- Util$doNotUse() + @category Bool value <- Util.doNotUse() run () { value <- false @@ -198,7 +198,7 @@ testcase "@category member init when ignored" { - crash Test$run() + crash Test.run() require "do not use" } @@ -213,7 +213,7 @@ } define Test { - @category Bool value <- Util$doNotUse() + @category Bool value <- Util.doNotUse() run () { \ value @@ -226,7 +226,7 @@ testcase "@category member inline assignment" { - success Test$run() + success Test.run() } define Test { @@ -250,7 +250,7 @@ testcase "@category init cycle" { - crash Test$run() + crash Test.run() require "Value1|Value2" } @@ -263,7 +263,7 @@ } define Value1 { - @category Bool value <- Value2$get() + @category Bool value <- Value2.get() get () { return value @@ -271,7 +271,7 @@ } define Value2 { - @category Bool value <- Value1$get() + @category Bool value <- Value1.get() get () { return value @@ -280,7 +280,7 @@ define Test { run () { - \ Value1$get() + \ Value1.get() } } diff --git a/tests/modifed-storage.0rt b/tests/modifed-storage.0rt deleted file mode 100644 --- a/tests/modifed-storage.0rt +++ /dev/null @@ -1,268 +0,0 @@ -/* ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry - -Licensed under the Apache License, Version 2.0 (the "License"); -you may not use this file except in compliance with the License. -You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - -Unless required by applicable law or agreed to in writing, software -distributed under the License is distributed on an "AS IS" BASIS, -WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -See the License for the specific language governing permissions and -limitations under the License. ------------------------------------------------------------------------------ */ - -// Author: Kevin P. Barry [ta0kira@gmail.com] - -testcase "optional persists" { - success Test$run() -} - -define Test { - @value optional Test self2 - - @type create () -> (Test) - create () { - return Test{ empty } - } - - @value set () -> () - set () { - scoped { - Test value <- create() - } in self2 <- value - } - - @value check () -> () - check () { - \ require(self2) - } - - run () { - Test value <- create() - \ value.set() - \ value.check() - } -} - -concrete Test { - @type run () -> () -} - - -testcase "weak is weak" { - success Test$run() -} - -define Test { - @value weak Test self2 - - @type create () -> (Test) - create () { - return Test{ empty } - } - - @value set () -> () - set () { - scoped { - Test value <- create() - } in self2 <- value - } - - @value check () -> () - check () { - scoped { - optional Test self3 <- strong(self2) - } in if (present(self3)) { - fail("Failed") - } - } - - run () { - Test value <- create() - \ value.set() - \ value.check() - } -} - -concrete Test { - @type run () -> () -} - - -testcase "present weak" { - success Test$run() -} - -define Test { - @type create () -> (Test) - create () { - return Test{} - } - - @value check () -> () - check () { - weak Test value <- create() - if (present(strong(value))) { // value should be nullptr here - fail("Failed") - } - } - - run () { - Test value <- create() - \ value.check() - } -} - -concrete Test { - @type run () -> () -} - - -testcase "weak variable to weak variable" { - success Test$run() -} - -define Test { - @category weak Test one <- empty - - run () { - weak Test two <- one - one <- two - } -} - -concrete Test { - @type run () -> () -} - - -testcase "optional variable to weak variable" { - success Test$run() -} - -define Test { - @category optional Test one <- empty - - run () { - weak Test two <- one - two <- one - } -} - -concrete Test { - @type run () -> () -} - - -testcase "weak in multi assign" { - success Test$run() -} - -concrete Value { - @type create () -> (Value) -} - -define Value { - create () { - return Value{} - } -} - -define Test { - @type get () -> (Value,Value) - get () { - Value value <- Value$create() - return value, value - } - - run () { - // value1 ensures value2 is present. - Value value1, weak Value value2 <- get() - if (!present(strong(value2))) { - fail("Failed") - } - } -} - -concrete Test { - @type run () -> () -} - - -testcase "weak in inline assign" { - success Test$run() -} - -concrete Value { - @type create () -> (Value) -} - -define Value { - create () { - return Value{} - } -} - -define Test { - run () { - Value value1 <- Value$create() - weak Value value2 <- empty - if (!present(strong((value2 <- value1)))) { - fail("Failed") - } - } -} - -concrete Test { - @type run () -> () -} - - -testcase "present required" { - success Test$run() -} - -define Test { - @type create () -> (Test) - create () { - return Test{} - } - - run () { - Test value <- create() - if (!present(value)) { - fail("Failed") - } - } -} - -concrete Test { - @type run () -> () -} - - -testcase "require required" { - success Test$run() -} - -define Test { - @type create () -> (Test) - create () { - return Test{} - } - - @value call () -> () - call () {} - - run () { - Test value <- create() - \ require(value).call() - } -} - -concrete Test { - @type run () -> () -} diff --git a/tests/modified-storage.0rt b/tests/modified-storage.0rt new file mode 100644 --- /dev/null +++ b/tests/modified-storage.0rt @@ -0,0 +1,268 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "optional persists" { + success Test.run() +} + +define Test { + @value optional Test self2 + + @type create () -> (Test) + create () { + return Test{ empty } + } + + @value set () -> () + set () { + scoped { + Test value <- create() + } in self2 <- value + } + + @value check () -> () + check () { + \ require(self2) + } + + run () { + Test value <- create() + \ value.set() + \ value.check() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "weak is weak" { + success Test.run() +} + +define Test { + @value weak Test self2 + + @type create () -> (Test) + create () { + return Test{ empty } + } + + @value set () -> () + set () { + scoped { + Test value <- create() + } in self2 <- value + } + + @value check () -> () + check () { + scoped { + optional Test self3 <- strong(self2) + } in if (present(self3)) { + fail("Failed") + } + } + + run () { + Test value <- create() + \ value.set() + \ value.check() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "present weak" { + success Test.run() +} + +define Test { + @type create () -> (Test) + create () { + return Test{} + } + + @value check () -> () + check () { + weak Test value <- create() + if (present(strong(value))) { // value should be nullptr here + fail("Failed") + } + } + + run () { + Test value <- create() + \ value.check() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "weak variable to weak variable" { + success Test.run() +} + +define Test { + @category weak Test one <- empty + + run () { + weak Test two <- one + one <- two + } +} + +concrete Test { + @type run () -> () +} + + +testcase "optional variable to weak variable" { + success Test.run() +} + +define Test { + @category optional Test one <- empty + + run () { + weak Test two <- one + two <- one + } +} + +concrete Test { + @type run () -> () +} + + +testcase "weak in multi assign" { + success Test.run() +} + +concrete Value { + @type create () -> (Value) +} + +define Value { + create () { + return Value{} + } +} + +define Test { + @type get () -> (Value,Value) + get () { + Value value <- Value.create() + return value, value + } + + run () { + // value1 ensures value2 is present. + Value value1, weak Value value2 <- get() + if (!present(strong(value2))) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "weak in inline assign" { + success Test.run() +} + +concrete Value { + @type create () -> (Value) +} + +define Value { + create () { + return Value{} + } +} + +define Test { + run () { + Value value1 <- Value.create() + weak Value value2 <- empty + if (!present(strong((value2 <- value1)))) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "present required" { + success Test.run() +} + +define Test { + @type create () -> (Test) + create () { + return Test{} + } + + run () { + Test value <- create() + if (!present(value)) { + fail("Failed") + } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "require required" { + success Test.run() +} + +define Test { + @type create () -> (Test) + create () { + return Test{} + } + + @value call () -> () + call () {} + + run () { + Test value <- create() + \ require(value).call() + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/module-only3/.zeolite-module b/tests/module-only3/.zeolite-module new file mode 100644 --- /dev/null +++ b/tests/module-only3/.zeolite-module @@ -0,0 +1,10 @@ +root: "../.." +path: "tests/module-only3" +private_deps: [ + "internal" +] +extra_files: [ + "tests/module-only3/source1.cpp" + "tests/module-only3/source2.cpp" +] +mode: incremental {} diff --git a/tests/module-only3/README.md b/tests/module-only3/README.md new file mode 100644 --- /dev/null +++ b/tests/module-only3/README.md @@ -0,0 +1,24 @@ +# `$ModuleOnly$` Pragma Test - Visibility in C++ + +Compiling this module should **always fail**. It tests that the `$ModuleOnly$` +pragma limits visibility even in C++ source files. + +To compile: + +```shell +ZEOLITE_PATH=$(zeolite --get-path) +zeolite -p $ZEOLITE_PATH -R tests/module-only3 +``` + +The compiler errors should look something like this: + +```text +tests/module-only3/source1.cpp:19:10: fatal error: 'Category_Type1.hpp' file not found +#include "Category_Type1.hpp" + ^~~~~~~~~~~~~~~~~~~~ +1 error generated. +Execution of /usr/bin/clang++ failed + +``` + +Importantly, there *should not* be any errors related to `Type2`; only `Type1`. diff --git a/tests/module-only3/internal/.zeolite-module b/tests/module-only3/internal/.zeolite-module new file mode 100644 --- /dev/null +++ b/tests/module-only3/internal/.zeolite-module @@ -0,0 +1,3 @@ +root: "../../.." +path: "tests/module-only3/internal" +mode: incremental {} diff --git a/tests/module-only3/internal/private.0rp b/tests/module-only3/internal/private.0rp new file mode 100644 --- /dev/null +++ b/tests/module-only3/internal/private.0rp @@ -0,0 +1,21 @@ +/* ----------------------------------------------------------------------------- +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] + +$ModuleOnly$ + +@value interface Type1 {} diff --git a/tests/module-only3/internal/public.0rp b/tests/module-only3/internal/public.0rp new file mode 100644 --- /dev/null +++ b/tests/module-only3/internal/public.0rp @@ -0,0 +1,19 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +@value interface Type2 {} diff --git a/tests/module-only3/source1.cpp b/tests/module-only3/source1.cpp new file mode 100644 --- /dev/null +++ b/tests/module-only3/source1.cpp @@ -0,0 +1,25 @@ +/* ----------------------------------------------------------------------------- +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_Type1.hpp" + +namespace { + +const TypeCategory& category = GetCategory_Type1(); + +} // namespace diff --git a/tests/module-only3/source2.cpp b/tests/module-only3/source2.cpp new file mode 100644 --- /dev/null +++ b/tests/module-only3/source2.cpp @@ -0,0 +1,25 @@ +/* ----------------------------------------------------------------------------- +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_Type2.hpp" + +namespace { + +const TypeCategory& category = GetCategory_Type2(); + +} // namespace diff --git a/tests/module-only4/.zeolite-module b/tests/module-only4/.zeolite-module new file mode 100644 --- /dev/null +++ b/tests/module-only4/.zeolite-module @@ -0,0 +1,10 @@ +root: "../.." +path: "tests/module-only4" +extra_files: [ + category_source { + source: "tests/module-only4/common-source.cpp" + categories: [Type1 Type3] + requires: [Type2] + } +] +mode: incremental {} diff --git a/tests/module-only4/README.md b/tests/module-only4/README.md new file mode 100644 --- /dev/null +++ b/tests/module-only4/README.md @@ -0,0 +1,12 @@ +# `$ModuleOnly$` Pragma Test - C++ Extension + +This module tests that the `$ModuleOnly$` categories can be defined and accessed +in C++ extensions in the same module. + +To compile and run the test: + +```shell +ZEOLITE_PATH=$(zeolite --get-path) +zeolite -p $ZEOLITE_PATH -r tests/module-only4 +zeolite -p $ZEOLITE_PATH -t tests/module-only4 +``` diff --git a/tests/module-only4/common-source.cpp b/tests/module-only4/common-source.cpp new file mode 100644 --- /dev/null +++ b/tests/module-only4/common-source.cpp @@ -0,0 +1,305 @@ +/* ----------------------------------------------------------------------------- +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_Formatted.hpp" +#include "Category_String.hpp" +#include "Category_Type1.hpp" +#include "Category_Type2.hpp" +#include "Category_Type3.hpp" + +#ifdef ZEOLITE_PRIVATE_NAMESPACE +namespace ZEOLITE_PRIVATE_NAMESPACE { +#endif // ZEOLITE_PRIVATE_NAMESPACE + +namespace { + +const int collection_Type1 = 0; +} // namespace + +const void* const Functions_Type1 = &collection_Type1; +const TypeFunction& Function_Type1_create = (*new TypeFunction{ 0, 0, 1, "Type1", "create", Functions_Type1, 0 }); +const ValueFunction& Function_Type1_get = (*new ValueFunction{ 0, 0, 1, "Type1", "get", Functions_Type1, 0 }); + +namespace { + +class Category_Type1; +class Type_Type1; +S CreateType_Type1(Params<0>::Type params); +class Value_Type1; +S CreateValue_Type1(Type_Type1& parent, const ParamTuple& params, const ValueTuple& args); + +struct Category_Type1 : public TypeCategory { + std::string CategoryName() const final { return "Type1"; } + Category_Type1() { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("Type1 (init @category)") + } + ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Category_Type1::*)(const ParamTuple&, const ValueTuple&); + return TypeCategory::Dispatch(label, params, args); + } +}; + +Category_Type1& CreateCategory_Type1() { + static auto& category = *new Category_Type1(); + return category; +} + +struct Type_Type1 : public TypeInstance { + std::string CategoryName() const final { return parent.CategoryName(); } + void BuildTypeName(std::ostream& output) const final { + return TypeInstance::TypeNameFrom(output, parent); + } + Category_Type1& parent; + bool CanConvertFrom(const S& from) const final { + std::vector> args; + if (!from->TypeArgsForParent(parent, args)) return false; + if(args.size() != 0) { + FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); + } + return true; + } + bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { + if (&category == &GetCategory_Type1()) { + args = std::vector>{}; + return true; + } + return false; + } + Type_Type1(Category_Type1& p, Params<0>::Type params) : parent(p) { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("Type1 (init @type)") + } + ReturnTuple Dispatch(const S& self, const TypeFunction& label, + const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Type_Type1::*)(const S&, const ParamTuple&, const ValueTuple&); + static const CallType Table_Type1[] = { + &Type_Type1::Call_create, + }; + if (label.collection == Functions_Type1) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_Type1[label.function_num])(self, params, args); + } + return TypeInstance::Dispatch(self, label, params, args); + } + ReturnTuple Call_create(const S& self, const ParamTuple& params, const ValueTuple& args); +}; + +S CreateType_Type1(Params<0>::Type params) { + static const auto cached = S_get(new Type_Type1(CreateCategory_Type1(), Params<0>::Type())); + return cached; +} + +struct Value_Type1 : public TypeValue { + Value_Type1(Type_Type1& p, const ParamTuple& params, const ValueTuple& args) + : parent(p), value(args.Only()) {} + + ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { + using CallType = ReturnTuple(Value_Type1::*)(const S&, const ParamTuple&, const ValueTuple&); + static const CallType Table_Type1[] = { + &Value_Type1::Call_get, + }; + if (label.collection == Functions_Type1) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_Type1[label.function_num])(self, params, args); + } + return TypeValue::Dispatch(self, label, params, args); + } + std::string CategoryName() const final { return parent.CategoryName(); } + ReturnTuple Call_get(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + Type_Type1& parent; + const S value; +}; + +S CreateValue_Type1(Type_Type1& parent, const ParamTuple& params, const ValueTuple& args) { + return S_get(new Value_Type1(parent, params, args)); +} + +ReturnTuple Type_Type1::Call_create(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Type1.create") + return ReturnTuple(CreateValue_Type1(*this, ParamTuple(), + TypeInstance::Call(GetType_Type2(Params<0>::Type()), Function_Type2_create, ParamTuple(), ArgTuple()))); +} + +ReturnTuple Value_Type1::Call_get(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Type1.get") + return ReturnTuple(TypeValue::Call(value, Function_Type2_get, ParamTuple(), ArgTuple())); +} + +} // namespace + +TypeCategory& GetCategory_Type1() { + return CreateCategory_Type1(); +} + +S GetType_Type1(Params<0>::Type params) { + return CreateType_Type1(params); +} + +#ifdef ZEOLITE_PRIVATE_NAMESPACE +} // namespace ZEOLITE_PRIVATE_NAMESPACE +using namespace ZEOLITE_PRIVATE_NAMESPACE; +#endif // ZEOLITE_PRIVATE_NAMESPACE + + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE + +namespace { + +const int collection_Type3 = 0; +} // namespace + +const void* const Functions_Type3 = &collection_Type3; +const TypeFunction& Function_Type3_create = (*new TypeFunction{ 0, 0, 1, "Type3", "create", Functions_Type3, 0 }); +const ValueFunction& Function_Type3_get = (*new ValueFunction{ 0, 0, 1, "Type3", "get", Functions_Type3, 0 }); + +namespace { + +class Category_Type3; +class Type_Type3; +S CreateType_Type3(Params<0>::Type params); +class Value_Type3; +S CreateValue_Type3(Type_Type3& parent, const ParamTuple& params, const ValueTuple& args); + +struct Category_Type3 : public TypeCategory { + std::string CategoryName() const final { return "Type3"; } + Category_Type3() { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("Type3 (init @category)") + } + ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Category_Type3::*)(const ParamTuple&, const ValueTuple&); + return TypeCategory::Dispatch(label, params, args); + } +}; + +Category_Type3& CreateCategory_Type3() { + static auto& category = *new Category_Type3(); + return category; +} + +struct Type_Type3 : public TypeInstance { + std::string CategoryName() const final { return parent.CategoryName(); } + void BuildTypeName(std::ostream& output) const final { + return TypeInstance::TypeNameFrom(output, parent); + } + Category_Type3& parent; + bool CanConvertFrom(const S& from) const final { + std::vector> args; + if (!from->TypeArgsForParent(parent, args)) return false; + if(args.size() != 0) { + FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); + } + return true; + } + bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { + if (&category == &GetCategory_Type3()) { + args = std::vector>{}; + return true; + } + return false; + } + Type_Type3(Category_Type3& p, Params<0>::Type params) : parent(p) { + CycleCheck::Check(); + CycleCheck marker(*this); + TRACE_FUNCTION("Type3 (init @type)") + } + ReturnTuple Dispatch(const S& self, const TypeFunction& label, + const ParamTuple& params, const ValueTuple& args) final { + using CallType = ReturnTuple(Type_Type3::*)(const S&, const ParamTuple&, const ValueTuple&); + static const CallType Table_Type3[] = { + &Type_Type3::Call_create, + }; + if (label.collection == Functions_Type3) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_Type3[label.function_num])(self, params, args); + } + return TypeInstance::Dispatch(self, label, params, args); + } + ReturnTuple Call_create(const S& self, const ParamTuple& params, const ValueTuple& args); +}; + +S CreateType_Type3(Params<0>::Type params) { + static const auto cached = S_get(new Type_Type3(CreateCategory_Type3(), Params<0>::Type())); + return cached; +} + +struct Value_Type3 : public TypeValue { + Value_Type3(Type_Type3& p, const ParamTuple& params, const ValueTuple& args) + : parent(p), value(args.Only()) {} + + ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { + using CallType = ReturnTuple(Value_Type3::*)(const S&, const ParamTuple&, const ValueTuple&); + static const CallType Table_Type3[] = { + &Value_Type3::Call_get, + }; + if (label.collection == Functions_Type3) { + if (label.function_num < 0 || label.function_num >= 1) { + FAIL() << "Bad function call " << label; + } + return (this->*Table_Type3[label.function_num])(self, params, args); + } + return TypeValue::Dispatch(self, label, params, args); + } + std::string CategoryName() const final { return parent.CategoryName(); } + ReturnTuple Call_get(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + Type_Type3& parent; + const S value; +}; + +S CreateValue_Type3(Type_Type3& parent, const ParamTuple& params, const ValueTuple& args) { + return S_get(new Value_Type3(parent, params, args)); +} + +ReturnTuple Type_Type3::Call_create(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Type3.create") + return ReturnTuple(CreateValue_Type3(*this, ParamTuple(), + TypeInstance::Call(GetType_Type2(Params<0>::Type()), Function_Type2_create, ParamTuple(), ArgTuple()))); +} + +ReturnTuple Value_Type3::Call_get(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Type3.get") + return ReturnTuple(TypeValue::Call(value, Function_Type2_get, ParamTuple(), ArgTuple())); +} + +} // namespace + +TypeCategory& GetCategory_Type3() { + return CreateCategory_Type3(); +} + +S GetType_Type3(Params<0>::Type params) { + return CreateType_Type3(params); +} + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/tests/module-only4/private.0rp b/tests/module-only4/private.0rp new file mode 100644 --- /dev/null +++ b/tests/module-only4/private.0rp @@ -0,0 +1,31 @@ +/* ----------------------------------------------------------------------------- +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] + +$ModuleOnly$ + +// Defined in common-source.cpp. +concrete Type1 { + @type create () -> (Type1) + @value get () -> (String) +} + +// Defined in private.0rx. +concrete Type2 { + @type create () -> (Type2) + @value get () -> (String) +} diff --git a/tests/module-only4/private.0rx b/tests/module-only4/private.0rx new file mode 100644 --- /dev/null +++ b/tests/module-only4/private.0rx @@ -0,0 +1,27 @@ +/* ----------------------------------------------------------------------------- +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 Type2 { + create () { + return Type2{} + } + + get () { + return "message" + } +} diff --git a/tests/module-only4/public.0rp b/tests/module-only4/public.0rp new file mode 100644 --- /dev/null +++ b/tests/module-only4/public.0rp @@ -0,0 +1,23 @@ +/* ----------------------------------------------------------------------------- +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] + +// Defined in common-source.cpp. +concrete Type3 { + @type create () -> (Type3) + @value get () -> (String) +} diff --git a/tests/multiple-returns.0rt b/tests/multiple-returns.0rt --- a/tests/multiple-returns.0rt +++ b/tests/multiple-returns.0rt @@ -65,7 +65,7 @@ testcase "multi return assign" { - success Test$run() + success Test.run() } define Test { @@ -92,7 +92,7 @@ testcase "multi return as args" { - success Test$run() + success Test.run() } define Test { diff --git a/tests/named-returns.0rt b/tests/named-returns.0rt --- a/tests/named-returns.0rt +++ b/tests/named-returns.0rt @@ -36,7 +36,7 @@ testcase "assign before logical" { - success Test$run() + success Test.run() } define Test { @@ -73,7 +73,7 @@ testcase "assign before arithmetic" { - success Test$run() + success Test.run() } define Test { @@ -91,7 +91,7 @@ testcase "assign after arithmetic" { - success Test$run() + success Test.run() } define Test { @@ -128,7 +128,7 @@ testcase "return used after assigned" { - success Test$run() + success Test.run() } define Test { @@ -151,8 +151,27 @@ } +testcase "return used as return before assigned" { + error + require "value.+initialized" +} + +define Test { + @category process () -> (Int) + process () (value) { + return value + } + + run () {} +} + +concrete Test { + @type run () -> () +} + + testcase "returns in correct order" { - success Test$run() + success Test.run() } define Test { @@ -178,7 +197,7 @@ testcase "assigns in correct order" { - success Test$run() + success Test.run() } concrete Value { @@ -195,7 +214,7 @@ @type get () -> (Value,Int,Int) get () (v,x,y) { // This makes sure that x and y (primitive) are offset. - v <- Value$create() + v <- Value.create() x <- 1 y <- 2 } @@ -217,7 +236,7 @@ testcase "assigns in correct order with explicit return" { - success Test$run() + success Test.run() } define Test { @@ -245,7 +264,7 @@ testcase "positional return sets named return" { - crash Test$run() + crash Test.run() require "message" } diff --git a/tests/positional-returns.0rt b/tests/positional-returns.0rt --- a/tests/positional-returns.0rt +++ b/tests/positional-returns.0rt @@ -36,7 +36,7 @@ testcase "positional return with no names assigned" { - success Test$run() + success Test.run() } define Test { @@ -67,7 +67,7 @@ testcase "positional return instead of names" { - success Test$run() + success Test.run() } define Test { @@ -93,7 +93,7 @@ testcase "positional return with some names assigned" { - success Test$run() + success Test.run() } define Test { diff --git a/tests/reduce.0rt b/tests/reduce.0rt --- a/tests/reduce.0rt +++ b/tests/reduce.0rt @@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "reduce to self" { - success Test$run() + success Test.run() } concrete Value { @@ -32,7 +32,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() scoped { optional Value value2 <- reduce(value) } in if (!present(value2)) { @@ -47,7 +47,7 @@ testcase "reduce to unrelated" { - success Test$run() + success Test.run() } concrete Value { @@ -62,7 +62,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() scoped { optional Test value2 <- reduce(value) } in if (present(value2)) { @@ -93,7 +93,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() optional Value value2 <- reduce(value) } } @@ -120,7 +120,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() optional Value value2 <- reduce(value) } } @@ -131,7 +131,7 @@ testcase "reduce success with param" { - success Test$run() + success Test.run() } concrete Value<|#x> { @@ -159,7 +159,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() scoped { optional Value value2 <- value.attempt() } in if (!present(value2)) { @@ -174,7 +174,7 @@ testcase "reduce fail with param" { - success Test$run() + success Test.run() } concrete Value<|#x> { @@ -202,7 +202,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() scoped { optional Value value2 <- value.attempt() } in if (present(value2)) { @@ -217,7 +217,7 @@ testcase "reduce success with contra param" { - success Test$run() + success Test.run() } concrete Value<#x|> { @@ -245,7 +245,7 @@ define Test { run () { - Value> value <- Value>$create() + Value> value <- Value>.create() scoped { optional Value> value2 <- value.attempt>() } in if (!present(value2)) { @@ -260,7 +260,7 @@ testcase "reduce fail with contra param" { - success Test$run() + success Test.run() } concrete Value<#x|> { @@ -288,7 +288,7 @@ define Test { run () { - Value> value <- Value>$create() + Value> value <- Value>.create() scoped { optional Value> value2 <- value.attempt>() } in if (present(value2)) { @@ -303,7 +303,7 @@ testcase "reduce success from union" { - success Test$run() + success Test.run() } @value interface Base {} @@ -326,7 +326,7 @@ define Test { run () { - [Value1|Value2] value <- Value1$create() + [Value1|Value2] value <- Value1.create() scoped { optional Base value2 <- reduce<[Value1|Value2],Base>(value) } in if (!present(value2)) { @@ -341,7 +341,7 @@ testcase "reduce fail from union" { - success Test$run() + success Test.run() } @value interface Base {} @@ -364,7 +364,7 @@ define Test { run () { - [Value1|Value2] value <- Value1$create() + [Value1|Value2] value <- Value1.create() scoped { optional Value2 value2 <- reduce<[Value1|Value2],Value2>(value) } in if (present(value2)) { @@ -379,7 +379,7 @@ testcase "reduce success to intersect" { - success Test$run() + success Test.run() } @value interface Base1 {} @@ -401,7 +401,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() scoped { optional [Base1&Base2] value2 <- reduce(value) } in if (!present(value2)) { @@ -416,7 +416,7 @@ testcase "reduce fail to intersect" { - success Test$run() + success Test.run() } @value interface Base1 {} @@ -437,7 +437,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() scoped { optional [Base1&Base2] value2 <- reduce(value) } in if (present(value2)) { @@ -452,7 +452,7 @@ testcase "reduce success union to intersect" { - success Test$run() + success Test.run() } @value interface Base1 {} @@ -479,7 +479,7 @@ define Test { run () { - [Value1|Value2] value <- Value2$create() + [Value1|Value2] value <- Value2.create() scoped { optional [Base1&Base2] value2 <- reduce<[Value1|Value2],[Base1&Base2]>(value) } in if (!present(value2)) { @@ -494,7 +494,7 @@ testcase "reduce fail union to intersect" { - success Test$run() + success Test.run() } @value interface Base1 {} @@ -520,7 +520,7 @@ define Test { run () { - [Value1|Value2] value <- Value2$create() + [Value1|Value2] value <- Value2.create() scoped { optional [Base1&Base2] value2 <- reduce<[Value1|Value2],[Base1&Base2]>(value) } in if (present(value2)) { @@ -535,7 +535,7 @@ testcase "reduce success intersect to union" { - success Test$run() + success Test.run() } @value interface Base1 {} @@ -563,7 +563,7 @@ define Test { run () { - [Value1&Value2] value <- Data$create() + [Value1&Value2] value <- Data.create() scoped { optional [Base1|Base2] value2 <- reduce<[Value1&Value2],[Base1|Base2]>(value) } in if (!present(value2)) { @@ -578,7 +578,7 @@ testcase "reduce fail intersect to union" { - success Test$run() + success Test.run() } @value interface Base1 {} @@ -604,7 +604,7 @@ define Test { run () { - [Value1&Value2] value <- Data$create() + [Value1&Value2] value <- Data.create() scoped { optional [Base1|Base2] value2 <- reduce<[Value1&Value2],[Base1|Base2]>(value) } in if (present(value2)) { @@ -619,7 +619,7 @@ testcase "reduce succeeds to covariant any" { - success Test$run() + success Test.run() } concrete Value<|#x> { @@ -634,7 +634,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() scoped { optional Value value2 <- reduce,Value>(value) } in if (!present(value2)) { @@ -649,7 +649,7 @@ testcase "reduce succeeds to contravariant all" { - success Test$run() + success Test.run() } concrete Value<#x|> { @@ -664,7 +664,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() scoped { optional Value value2 <- reduce,Value>(value) } in if (!present(value2)) { @@ -679,7 +679,7 @@ testcase "reduce fails to invariant any" { - success Test$run() + success Test.run() } concrete Value<#x> { @@ -694,7 +694,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() scoped { optional Value value2 <- reduce,Value>(value) } in if (present(value2)) { @@ -709,7 +709,7 @@ testcase "reduce succeeds from covariant all" { - success Test$run() + success Test.run() } concrete Value<|#x> { @@ -724,7 +724,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() scoped { optional Value value2 <- reduce,Value>(value) } in if (!present(value2)) { @@ -739,7 +739,7 @@ testcase "reduce succeeds from contravariant any" { - success Test$run() + success Test.run() } concrete Value<#x|> { @@ -754,7 +754,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() scoped { optional Value value2 <- reduce,Value>(value) } in if (!present(value2)) { @@ -769,7 +769,7 @@ testcase "reduce fails from invariant all" { - success Test$run() + success Test.run() } concrete Value<#x> { @@ -784,7 +784,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() scoped { optional Value value2 <- reduce,Value>(value) } in if (present(value2)) { @@ -829,7 +829,7 @@ testcase "reduce from interface" { - success Test$run() + success Test.run() } @value interface Base0 { @@ -852,7 +852,7 @@ define Test { run () { - if (!present(reduce(Value$create()))) { + if (!present(reduce(Value.create()))) { fail("Failed") } } @@ -864,7 +864,7 @@ testcase "reduce with internal override" { - success Test$run() + success Test.run() } @value interface Base0 {} @@ -890,10 +890,10 @@ define Test { run () { - if (!present(reduce>(Value$create()))) { + if (!present(reduce>(Value.create()))) { fail("Failed") } - if (present(reduce>(Value$create()))) { + if (present(reduce>(Value.create()))) { fail("Failed") } } diff --git a/tests/regressions.0rt b/tests/regressions.0rt --- a/tests/regressions.0rt +++ b/tests/regressions.0rt @@ -37,7 +37,7 @@ // Value<#y> gets subbed in for #x, so call is re-parameterized with an // argument of type Value<#y>. When the compiler processes call, it // looks for #y, which it finds; however, it's a different #y. - \ Type1>$call(Value<#y>$create()) + \ Type1>.call(Value<#y>.create()) } } diff --git a/tests/scoped.0rt b/tests/scoped.0rt --- a/tests/scoped.0rt +++ b/tests/scoped.0rt @@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "scoped unconditional" { - success Test$run() + success Test.run() } @value interface Value {} @@ -60,7 +60,7 @@ testcase "return inside scope" { - success Test$run() + success Test.run() } @@ -83,7 +83,7 @@ testcase "return from scoped" { - success Test$run() + success Test.run() } @value interface Value {} @@ -125,7 +125,7 @@ testcase "assign inside scope" { - success Test$run() + success Test.run() } @value interface Value {} @@ -147,7 +147,7 @@ testcase "assign from scoped" { - success Test$run() + success Test.run() } @value interface Value {} @@ -168,7 +168,7 @@ testcase "simple cleanup" { - success Test$run() + success Test.run() } define Test { @@ -211,7 +211,7 @@ testcase "cleanup before return" { - success Test$run() + success Test.run() } concrete Value { @@ -243,7 +243,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() Int value1 <- value.call() if (value1 != 2) { fail(value1) @@ -261,7 +261,7 @@ testcase "positional return sets named returns for cleanup" { - crash Test$run() + crash Test.run() require "message" exclude "failed" } @@ -313,7 +313,7 @@ testcase "cleanup skipped in scoped return" { - success Test$run() + success Test.run() } define Test { @@ -342,7 +342,7 @@ testcase "multiple cleanup" { - success Test$run() + success Test.run() } define Test { @@ -377,7 +377,7 @@ testcase "multiple cleanup with return" { - success Test$run() + success Test.run() } concrete Value { @@ -417,7 +417,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() Int value1, Int value2, Int value3 <- value.call() if (value1 != 1) { fail(value1) @@ -488,7 +488,7 @@ testcase "no name clash in nested scope with return" { - success Test$run() + success Test.run() } define Test { @@ -509,7 +509,7 @@ testcase "cleanup skipped for fail" { - crash Test$run() + crash Test.run() require "scoped" } @@ -529,7 +529,7 @@ testcase "cleanup not applied to returns outside of scope" { - success Test$run() + success Test.run() } define Test { @@ -553,7 +553,7 @@ testcase "cleanup unconditional" { - success Test$run() + success Test.run() } @value interface Value {} @@ -574,7 +574,7 @@ testcase "scoped empty blocks" { - success Test$run() + success Test.run() } @value interface Value {} @@ -597,7 +597,7 @@ testcase "just cleanup" { - success Test$run() + success Test.run() } concrete Value { @@ -626,7 +626,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() Int value1 <- value.postIncrement() if (value1 != 0) { fail(value1) @@ -644,7 +644,7 @@ testcase "separate trace context for cleanup" { - crash Test$run() + crash Test.run() require "Failed" require "cleanup block" require "Test\.run" @@ -666,7 +666,7 @@ testcase "partial cleanup with while and break" { - success Test$run() + success Test.run() } define Test { @@ -688,13 +688,13 @@ } } } - \ Testing$check(x,0) - \ Testing$check(y,2) - \ Testing$check(z,3) + \ Testing.check(x,0) + \ Testing.check(y,2) + \ Testing.check(z,3) } - \ Testing$check(x,1) - \ Testing$check(y,2) - \ Testing$check(z,3) + \ Testing.check(x,1) + \ Testing.check(y,2) + \ Testing.check(z,3) } } @@ -704,7 +704,7 @@ testcase "full cleanup with while and return" { - success Test$run() + success Test.run() } concrete Value { @@ -746,20 +746,20 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() scoped { Int x, Int y, Int z <- value.call() } in { - \ Testing$check(x,0) - \ Testing$check(y,0) - \ Testing$check(z,0) + \ Testing.check(x,0) + \ Testing.check(y,0) + \ Testing.check(z,0) } scoped { Int x, Int y, Int z <- value.get() } in { - \ Testing$check(x,1) - \ Testing$check(y,2) - \ Testing$check(z,3) + \ Testing.check(x,1) + \ Testing.check(y,2) + \ Testing.check(z,3) } } } diff --git a/tests/simple.0rt b/tests/simple.0rt --- a/tests/simple.0rt +++ b/tests/simple.0rt @@ -36,7 +36,7 @@ testcase "basic crash test" { - crash Test$execute() + crash Test.execute() require stderr "/testcase:" require stderr "failure message!!!" exclude stdout "failure message!!!" @@ -56,7 +56,7 @@ testcase "basic success test" { - success Test$execute() + success Test.execute() } concrete Test { @@ -85,7 +85,7 @@ testcase "no deadlock with recursive type" { - success Test$execute() + success Test.execute() } concrete Test { @@ -102,13 +102,13 @@ define Test { execute () { - \ Type>>$call() + \ Type>>.call() } } testcase "ModuleOnly is visible to tests" { - success Test$execute() + success Test.execute() } concrete Test { diff --git a/tests/templates/tests.0rt b/tests/templates/tests.0rt --- a/tests/templates/tests.0rt +++ b/tests/templates/tests.0rt @@ -17,13 +17,13 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "template compiles to binary" { - crash Test$run() + crash Test.run() require "Templated\.create is not implemented" } define Test { run () { - \ Templated$create() + \ Templated.create() } } diff --git a/tests/tests-only3/.zeolite-module b/tests/tests-only3/.zeolite-module new file mode 100644 --- /dev/null +++ b/tests/tests-only3/.zeolite-module @@ -0,0 +1,3 @@ +root: "../.." +path: "tests/tests-only3" +mode: incremental {} diff --git a/tests/tests-only3/README.md b/tests/tests-only3/README.md new file mode 100644 --- /dev/null +++ b/tests/tests-only3/README.md @@ -0,0 +1,20 @@ +# `$TestsOnly$` Visibility Test - Conflicting Definition and Declaration + +Compiling this module should **always fail**. It tests that a category +*declared* in a non-`$TestsOnly$` `.0rp` cannot be *defined* in a `$TestsOnly$` +`.0rx`. + +To compile: + +```shell +ZEOLITE_PATH=$(zeolite --get-path) +zeolite -p $ZEOLITE_PATH -r tests/tests-only3 +``` + +The compiler errors should look something like this: + +```text +Zeolite execution failed. + In compilation of module "/home/ta0kira/checkouts/zeolite/tests/tests-only3" + Category NotTestsOnly ["tests/tests-only3/public.0rx" (line 21, column 1)] was not declared as $TestsOnly$ ["tests/tests-only3/public.0rp" (line 19, column 1)] +``` diff --git a/tests/tests-only3/public.0rp b/tests/tests-only3/public.0rp new file mode 100644 --- /dev/null +++ b/tests/tests-only3/public.0rp @@ -0,0 +1,19 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +concrete NotTestsOnly {} diff --git a/tests/tests-only3/public.0rx b/tests/tests-only3/public.0rx new file mode 100644 --- /dev/null +++ b/tests/tests-only3/public.0rx @@ -0,0 +1,21 @@ +/* ----------------------------------------------------------------------------- +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] + +$TestsOnly$ + +define NotTestsOnly {} diff --git a/tests/tracing.0rt b/tests/tracing.0rt --- a/tests/tracing.0rt +++ b/tests/tracing.0rt @@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "NoTrace skips tracing" { - crash Test$run() + crash Test.run() require "message" require "Test\.run" require "Test\.error" @@ -46,7 +46,7 @@ testcase "TraceCreation captures trace" { - crash Test$run() + crash Test.run() require "message" require "Type.+created at" } @@ -68,7 +68,7 @@ define Test { run () { - Type value <- Type$create() + Type value <- Type.create() \ value.call() } } @@ -79,7 +79,7 @@ testcase "TraceCreation ignored in @type" { - success Test$run() + success Test.run() require compiler "tracing ignored" } @@ -93,7 +93,7 @@ testcase "TraceCreation still works with NoTrace" { - crash Test$run() + crash Test.run() require "message" require "Type.+created at" exclude "Type\.call" @@ -116,7 +116,7 @@ define Test { run () { - Type value <- Type$create() + Type value <- Type.create() \ value.call() } } @@ -127,7 +127,7 @@ testcase "TraceCreation only uses the latest" { - crash Test$run() + crash Test.run() require "message" require "Type1.+created at" exclude "Type2.+created at" @@ -157,7 +157,7 @@ @value Type1 value create () { - return Type2{ Type1$create() } + return Type2{ Type1.create() } } call () { $TraceCreation$ @@ -167,7 +167,7 @@ define Test { run () { - Type2 value <- Type2$create() + Type2 value <- Type2.create() \ value.call() } } diff --git a/tests/typename.0rt b/tests/typename.0rt --- a/tests/typename.0rt +++ b/tests/typename.0rt @@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "String typename" { - success Test$run() + success Test.run() } define Test { @@ -35,7 +35,7 @@ testcase "Int typename" { - success Test$run() + success Test.run() } define Test { @@ -53,7 +53,7 @@ testcase "Char typename" { - success Test$run() + success Test.run() } define Test { @@ -71,7 +71,7 @@ testcase "Float typename" { - success Test$run() + success Test.run() } define Test { @@ -89,7 +89,7 @@ testcase "Bool typename" { - success Test$run() + success Test.run() } define Test { @@ -107,7 +107,7 @@ testcase "Formatted typename" { - success Test$run() + success Test.run() } define Test { @@ -125,7 +125,7 @@ testcase "ReadPosition typename" { - success Test$run() + success Test.run() } define Test { @@ -143,7 +143,7 @@ testcase "any typename" { - success Test$run() + success Test.run() } define Test { @@ -161,7 +161,7 @@ testcase "all typename" { - success Test$run() + success Test.run() } define Test { @@ -179,13 +179,13 @@ testcase "intersect typename" { - success Test$run() + success Test.run() } define Test { run () { Formatted name <- typename<[String&Int]>() - if (name.formatted() != "[String&Int]") { + if (name.formatted() != "[Int&String]") { fail(name) } } @@ -197,13 +197,13 @@ testcase "union typename" { - success Test$run() + success Test.run() } define Test { run () { Formatted name <- typename<[String|Int]>() - if (name.formatted() != "[String|Int]") { + if (name.formatted() != "[Int|String]") { fail(name) } } @@ -215,7 +215,7 @@ testcase "param typename" { - success Test$run() + success Test.run() } @value interface Value<#x> {} diff --git a/tests/unary-functions.0rt b/tests/unary-functions.0rt --- a/tests/unary-functions.0rt +++ b/tests/unary-functions.0rt @@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "category unary" { - success Test$run() + success Test.run() } define Test { @@ -27,7 +27,7 @@ } run () { - Int value <- `Test$$neg` 2 + Int value <- `Test:neg` 2 if (value != -2) { fail(value) } @@ -40,7 +40,7 @@ testcase "type unary" { - success Test$run() + success Test.run() } define Test { @@ -50,7 +50,7 @@ } run () { - Int value <- `Test$neg` 2 + Int value <- `Test.neg` 2 if (value != -2) { fail(value) } @@ -63,7 +63,7 @@ testcase "value unary" { - success Test$run() + success Test.run() } concrete Arithmetic { @@ -83,7 +83,7 @@ define Test { run () { - Int value <- `Arithmetic$create().neg` 2 + Int value <- `Arithmetic.create().neg` 2 if (value != -2) { fail(value) } @@ -96,7 +96,7 @@ testcase "unqualified unary" { - success Test$run() + success Test.run() } define Test { @@ -119,7 +119,7 @@ testcase "unary function with infix function" { - success Test$run() + success Test.run() } define Test { diff --git a/tests/unreachable.0rt b/tests/unreachable.0rt --- a/tests/unreachable.0rt +++ b/tests/unreachable.0rt @@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "warning statement after fail" { - success Test$run() + success Test.run() require compiler "unreachable" } @@ -36,7 +36,7 @@ } testcase "unreachable not compiled" { - success Test$run() + success Test.run() } define Test { @@ -55,7 +55,7 @@ testcase "warning statement after return" { - success Test$run() + success Test.run() require compiler "unreachable" } @@ -75,7 +75,7 @@ testcase "warning statement after conditional return" { - success Test$run() + success Test.run() require compiler "unreachable" } @@ -99,7 +99,7 @@ testcase "warning statement after scoped return" { - success Test$run() + success Test.run() require compiler "unreachable" } @@ -120,7 +120,7 @@ testcase "warning statement after cleanup fail" { - crash Test$run() + crash Test.run() require compiler "unreachable" require "message" } @@ -146,7 +146,7 @@ testcase "warning statement in cleanup after scoped fail" { - crash Test$run() + crash Test.run() require compiler "unreachable" require "message" } @@ -172,7 +172,7 @@ testcase "warning statement in cleanup after in fail" { - crash Test$run() + crash Test.run() require compiler "unreachable" require "message" } @@ -196,7 +196,7 @@ testcase "warning statement after break" { - success Test$run() + success Test.run() require compiler "unreachable" } @@ -215,7 +215,7 @@ testcase "warning statement after continue" { - success Test$run() + success Test.run() require compiler "unreachable" } diff --git a/tests/value-init.0rt b/tests/value-init.0rt --- a/tests/value-init.0rt +++ b/tests/value-init.0rt @@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "value init in @category member" { - success Test$run() + success Test.run() } define Test { @@ -42,7 +42,7 @@ testcase "init value same type from @type" { - success Test$run() + success Test.run() } concrete Value<#x> { @@ -64,7 +64,7 @@ define Test { run () { - Value value <- Value$create(1) + Value value <- Value.create(1) if (value.get() != 1) { fail("Failed") } @@ -77,7 +77,7 @@ testcase "init value different type from @type" { - success Test$run() + success Test.run() } concrete Value<#x> { @@ -99,7 +99,7 @@ define Test { run () { - Value value <- Value$create(1) + Value value <- Value.create(1) if (value.get() != 1) { fail("Failed") } @@ -112,7 +112,7 @@ testcase "init value same type from @value" { - success Test$run() + success Test.run() } concrete Value<#x> { @@ -139,7 +139,7 @@ define Test { run () { - Value value <- Value$create(2).create2(1) + Value value <- Value.create(2).create2(1) if (value.get() != 1) { fail("Failed") } @@ -152,7 +152,7 @@ testcase "init value different type from @value" { - success Test$run() + success Test.run() } concrete Value<#x> { @@ -179,7 +179,7 @@ define Test { run () { - Value value <- Value$create("x").create2(1) + Value value <- Value.create("x").create2(1) if (value.get() != 1) { fail("Failed") } diff --git a/tests/visibility.0rt b/tests/visibility.0rt --- a/tests/visibility.0rt +++ b/tests/visibility.0rt @@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "public types in private deps stay hidden" { - success Test$run() + success Test.run() } // Internal is defined in visibility/internal and visibility2/internal. The @@ -40,15 +40,15 @@ define Test { run () { - String value1 <- Internal$create().get() + String value1 <- Internal.create().get() if (value1 != "message") { fail(value1) } - Int value2 <- Getter$getValue() + Int value2 <- Getter.getValue() if (value2 != 1) { fail(value2) } - Int value3 <- Getter2$getValue() + Int value3 <- Getter2.getValue() if (value3 != 2) { fail(value3) } diff --git a/tests/visibility/getter.0rx b/tests/visibility/getter.0rx --- a/tests/visibility/getter.0rx +++ b/tests/visibility/getter.0rx @@ -1,5 +1,5 @@ define Getter { getValue () { - return Internal$create().get() + return Internal.create().get() } } diff --git a/tests/visibility2/getter2.0rx b/tests/visibility2/getter2.0rx --- a/tests/visibility2/getter2.0rx +++ b/tests/visibility2/getter2.0rx @@ -1,5 +1,5 @@ define Getter2 { getValue () { - return Internal$create().get() + return Internal.create().get() } } diff --git a/tests/while.0rt b/tests/while.0rt --- a/tests/while.0rt +++ b/tests/while.0rt @@ -117,7 +117,7 @@ testcase "while with break" { - success Test$run() + success Test.run() } define Test { @@ -143,7 +143,7 @@ testcase "while with update" { - success Test$run() + success Test.run() } define Test { @@ -169,7 +169,7 @@ testcase "break in update" { - success Test$run() + success Test.run() } define Test { @@ -195,7 +195,7 @@ testcase "return in update" { - success Test$run() + success Test.run() } define Test { @@ -225,7 +225,7 @@ testcase "break and continue in if/else" { - success Test$run() + success Test.run() } define Test { @@ -253,7 +253,7 @@ testcase "update clashes with while" { - success Test$run() + success Test.run() } define Test { @@ -272,7 +272,7 @@ testcase "while without update" { - success Test$run() + success Test.run() } define Test { @@ -297,7 +297,7 @@ testcase "while with continue and update" { - success Test$run() + success Test.run() } define Test { @@ -325,7 +325,7 @@ testcase "while with continue and without update" { - success Test$run() + success Test.run() } define Test { @@ -352,7 +352,7 @@ testcase "crash in while" { - crash Test$run() + crash Test.run() require "empty" } @@ -371,7 +371,7 @@ testcase "cleanup after break" { - success Test$run() + success Test.run() } define Test { @@ -397,7 +397,7 @@ testcase "cleanup before return in while" { - success Test$run() + success Test.run() } concrete Value { @@ -432,7 +432,7 @@ define Test { run () { - Value value <- Value$create() + Value value <- Value.create() Int value1 <- value.call() if (value1 != 2) { fail(value1) diff --git a/zeolite-lang.cabal b/zeolite-lang.cabal --- a/zeolite-lang.cabal +++ b/zeolite-lang.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: zeolite-lang -version: 0.8.0.0 +version: 0.9.0.0 synopsis: Zeolite is a statically-typed, general-purpose programming language. description: @@ -92,6 +92,7 @@ lib/math/*.0rp, lib/math/*.0rt, lib/math/*.cpp, + lib/math/*.hpp, lib/util/.zeolite-module, lib/util/*.0rp, lib/util/*.0rt, @@ -114,6 +115,16 @@ tests/module-only2/README.md, tests/module-only2/.zeolite-module, tests/module-only2/*.0rp, + tests/module-only3/README.md, + tests/module-only3/.zeolite-module, + tests/module-only3/*.cpp, + tests/module-only3/internal/.zeolite-module, + tests/module-only3/internal/*.0rp, + tests/module-only4/README.md, + tests/module-only4/.zeolite-module, + tests/module-only4/*.cpp, + tests/module-only4/*.0rp, + tests/module-only4/*.0rx, tests/templates/README.md, tests/templates/.zeolite-module, tests/templates/*.0rp, @@ -126,6 +137,10 @@ tests/tests-only2/.zeolite-module, tests/tests-only2/*.0rp, tests/tests-only2/*.0rx, + tests/tests-only3/README.md, + tests/tests-only3/.zeolite-module, + tests/tests-only3/*.0rp, + tests/tests-only3/*.0rx, tests/visibility/.zeolite-module, tests/visibility/*.0rp, tests/visibility/*.0rx, @@ -224,7 +239,8 @@ FunctionalDependencies, MultiParamTypeClasses, Safe, - ScopedTypeVariables + ScopedTypeVariables, + TypeFamilies build-depends: base >= 4.8 && < 4.15, containers >= 0.3 && < 0.7, @@ -234,6 +250,7 @@ mtl >= 1.0 && < 2.3, parsec >= 3.0 && < 3.2, regex-tdfa >= 1.0 && < 1.4, + time >= 1.0 && < 1.11, transformers >= 0.1 && < 0.6, unix >= 2.6 && <= 2.8