diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,142 @@ # Revision history for zeolite-lang +## 0.16.0.0 -- 2021-04-01 + +### Language + +* **[breaking]** Disallows param filters in `@value interface` and + `@type interface`. Param filters are only used to allow procedures to call + `@type` and `@value` functions. Previously, they were enforced in all + situations where param substitution occurred, but this is no longer the case. + (See further down in this list.) + +* **[breaking]** Removes support for internal type params for values. This was + an obscure feature that was never documented and was only used in some + integration tests that had not been touched in over 2 years. This breaks most + hand-written C++ extensions, but they can be fixed by removing the + `ParamTuple` argument passed to the base-class constructor in `ExtValue_Foo` + for C++ extension `Foo`. + +* **[breaking]** Adds the `traverse` built-in syntax, which automatically + iterates over a container that exposes the (new) `Order<|#x>` + `@value interface`. (This is breaking because `traverse`, `Order`, and + `DefaultOrder` are now reserved.) + + ```text + traverse (container.defaultOrder() -> Foo value) { + // executed once per Foo in the container + } + ``` + +* **[breaking]** Marks `@category` member variables as read-only when + initializing other member variables. Essentially, this just means that you can + no longer do something like this: + + ```text + @category Int foo <- 1 + @category Int bar <- (foo <- 2) + ``` + +* **[new]** Removes the requirement that type instances (e.g., `Type`) + satisfy the requirements of the type's parameter filters when not being used + in a function call. + + ```text + concrete Type<|#x> { + #x requires Foo + } + ``` + + In the example above, `Type` was universally disallowed if `Bar` could + not be converted to `Foo`. The new behavior is to enforce that restriction + only when calling `@type` functions, initializing values (e.g., + `Type<#x>{ }`), and using the type as a param in a function call. + + Since `#x` is covariant in this example, you could convert a `Type` to a + `Type`, even though `any` is not a child of `Foo`. + +* **[new]** Removes variance checks for category-level param filters. Variance + was originally *not* checked, but then the checks were added prior to version + `0.1.0.0` for obscure mathematical reasons that no longer make sense. + + In particular, filters such as `#x defines Equals<#x>` *were not* previously + allowed except when `#x` was invariant, but now it is allowed for all + variances. + + The revised perspective is that param filters form a meta-type for param + substitutions as inputs, with the constructed type as the output. Once the + output is received, the input constraints are no longer recoverable. + + Note that category-level param variance is still checked when params are used + on the right side of filters for function params. This is because not doing so + could result in bad argument and return types when inheriting functions. + + Params also still cannot have *both* upper and lower bounds at the same time. + +* **[new]** When inferring type parameters for function calls (e.g., + `call(foo)`), allows `all` to be a valid lower bound and `any` to be a + valid upper bound. Previously, an inferred type of `all` in covariant + positions and `any` in contravariant positions would cause inference to fail. + +* **[new]** Allows `$ReadOnly[...]$` and `$Hidden[...]$` for member variables in + definitions of `concrete` categories. + +* **[new]** Makes `Argv` available to all threads. Previously, it was only + available to the main thread. (Even though `Argv` is exposed via `lib/util`, + this change also affects C++ extensions that use `Argv` from `logging.hpp`.) + +* **[fix]** Fixes regression with function names used in stack traces. + Previously, if a function was inherited and the types were not overridden, + the category name in the trace would be that of the parent, rather than that + of the one defining the procedure. + +### Compiler CLI + +* **[breaking]** Removes the default compiler mode when calling `zeolite`. The + previous default was `-c`, which creates a new `.zeolite-module` for + incremental library compilation. The default was removed because accidentally + typing `zeolite -f foo` instead of `zeolite -t foo` would overwrite the + `.zeolite-module` for `foo` rather than running its tests. + +* **[breaking]** Updates how `$TraceCreation$` is implemented in C++. This only + breaks hand-written C++ extensions that use the `CAPTURE_CREATION` macro, + which now must pass a string-literal category name as a macro argument, + e.g., `CAPTURE_CREATION("Foo")`. + +* **[new]** Adds the `--log-traces` option for testing mode (`zeolite -t`) to + capture a record of every line of Zeolite code executed when running tests. + +* **[fix]** Fixes dependency resolution for C++ extensions that define + `$ModuleOnly$` categories. + +* **[behavior]** Improves the efficiency of call dispatching and `reduce` calls + for categories that inherit a lot of `interface`s. This is unlikely to affect + performance when a category has less than 10 direct or indirect parent + `interface`s. + +### Libraries + +* **[new]** Adds `ThreadCondition` to `lib/thread`, which allows threads to wait + for an arbitrary condition signaled by another thread. (Similar to + `pthread_cond_t` in POSIX.) + +* **[new]** Adds `EnumeratedBarrier` to `lib/thread`, which can be use to + synchronize a fixed number of threads. (Similar to `pthread_barrier_t` in + POSIX, but with strict validation to help prevent deadlocks.) + +* **[new]** Adds `Realtime` to `lib/thread`, to allow threads to sleep based on + wall time. + +* **[new]** Adds `Counter` and `Repeat` to `lib/util`, to help create sequences + for use with the new `traverse` built-in syntax. + +* **[new]** Implements forward and reverse iteration to `SearchTree` in + `lib/container`. + +### Examples + +* Adds `example/primes`, as a demonstration of multithreading. + ## 0.15.0.0 -- 2021-03-24 ### Language diff --git a/base/Category_Bool.cpp b/base/Category_Bool.cpp --- a/base/Category_Bool.cpp +++ b/base/Category_Bool.cpp @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 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. @@ -41,7 +41,6 @@ class Category_Bool; class Type_Bool; class Value_Bool; -S CreateValue(Type_Bool& parent, const ParamTuple& params, const ValueTuple& args); struct Category_Bool : public TypeCategory { std::string CategoryName() const final { return "Bool"; } Category_Bool() { @@ -72,25 +71,34 @@ } return true; } + void Params_Bool(std::vector>& args) const { + args = std::vector>{}; + } + void Params_AsBool(std::vector>& args) const { + args = std::vector>{}; + } + void Params_AsInt(std::vector>& args) const { + args = std::vector>{}; + } + void Params_AsFloat(std::vector>& args) const { + args = std::vector>{}; + } + void Params_Formatted(std::vector>& args) const { + args = std::vector>{}; + } bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { - if (&category == &GetCategory_Bool()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_AsBool()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_AsInt()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_AsFloat()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_Formatted()) { - args = std::vector>{}; + using CallType = void(Type_Bool::*)(std::vector>&)const; + static DispatchSingle all_calls[] = { + DispatchSingle(&GetCategory_AsBool(), &Type_Bool::Params_AsBool), + DispatchSingle(&GetCategory_AsFloat(), &Type_Bool::Params_AsFloat), + DispatchSingle(&GetCategory_AsInt(), &Type_Bool::Params_AsInt), + DispatchSingle(&GetCategory_Bool(), &Type_Bool::Params_Bool), + DispatchSingle(&GetCategory_Formatted(), &Type_Bool::Params_Formatted), + DispatchSingle(), + }; + const DispatchSingle* const call = DispatchSelect(&category, all_calls); + if (call) { + (this->*call->value)(args); return true; } return false; @@ -109,18 +117,19 @@ static const CallType Table_Equals[] = { &Type_Bool::Call_equals, }; - if (label.collection == Functions_Default) { - if (label.function_num < 0 || label.function_num >= 1) { + static DispatchTable all_tables[] = { + DispatchTable(Functions_Default, Table_Default), + DispatchTable(Functions_Equals, Table_Equals), + DispatchTable(), + }; + const DispatchTable* const table = DispatchSelect(label.collection, all_tables); + if (table) { + if (label.function_num < 0 || label.function_num >= table->size) { FAIL() << "Bad function call " << label; + } else { + return (this->*table->table[label.function_num])(params, args); } - return (this->*Table_Default[label.function_num])(params, args); } - if (label.collection == Functions_Equals) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_Equals[label.function_num])(params, args); - } return TypeInstance::Dispatch(self, label, params, args); } ReturnTuple Call_default(const ParamTuple& params, const ValueTuple& args); @@ -146,29 +155,20 @@ static const CallType Table_Formatted[] = { &Value_Bool::Call_formatted, }; - if (label.collection == Functions_AsBool) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_AsBool[label.function_num])(self, params, args); - } - if (label.collection == Functions_AsFloat) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_AsFloat[label.function_num])(self, params, args); - } - if (label.collection == Functions_AsInt) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_AsInt[label.function_num])(self, params, args); - } - if (label.collection == Functions_Formatted) { - if (label.function_num < 0 || label.function_num >= 1) { + static DispatchTable all_tables[] = { + DispatchTable(Functions_AsBool, Table_AsBool), + DispatchTable(Functions_AsFloat, Table_AsFloat), + DispatchTable(Functions_AsInt, Table_AsInt), + DispatchTable(Functions_Formatted, Table_Formatted), + DispatchTable(), + }; + const DispatchTable* const table = DispatchSelect(label.collection, all_tables); + if (table) { + if (label.function_num < 0 || label.function_num >= table->size) { FAIL() << "Bad function call " << label; + } else { + return (this->*table->table[label.function_num])(self, params, args); } - return (this->*Table_Formatted[label.function_num])(self, params, args); } return TypeValue::Dispatch(self, label, params, args); } diff --git a/base/Category_Char.cpp b/base/Category_Char.cpp --- a/base/Category_Char.cpp +++ b/base/Category_Char.cpp @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 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. @@ -43,7 +43,6 @@ class Category_Char; class Type_Char; class Value_Char; -S CreateValue(Type_Char& parent, const ParamTuple& params, const ValueTuple& args); struct Category_Char : public TypeCategory { std::string CategoryName() const final { return "Char"; } Category_Char() { @@ -74,29 +73,38 @@ } return true; } + void Params_Char(std::vector>& args) const { + args = std::vector>{}; + } + void Params_AsBool(std::vector>& args) const { + args = std::vector>{}; + } + void Params_AsChar(std::vector>& args) const { + args = std::vector>{}; + } + void Params_AsInt(std::vector>& args) const { + args = std::vector>{}; + } + void Params_AsFloat(std::vector>& args) const { + args = std::vector>{}; + } + void Params_Formatted(std::vector>& args) const { + args = std::vector>{}; + } bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { - if (&category == &GetCategory_Char()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_AsBool()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_AsChar()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_AsInt()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_AsFloat()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_Formatted()) { - args = std::vector>{}; + using CallType = void(Type_Char::*)(std::vector>&)const; + static DispatchSingle all_calls[] = { + DispatchSingle(&GetCategory_AsBool(), &Type_Char::Params_AsBool), + DispatchSingle(&GetCategory_AsChar(), &Type_Char::Params_AsChar), + DispatchSingle(&GetCategory_AsFloat(), &Type_Char::Params_AsFloat), + DispatchSingle(&GetCategory_AsInt(), &Type_Char::Params_AsInt), + DispatchSingle(&GetCategory_Char(), &Type_Char::Params_Char), + DispatchSingle(&GetCategory_Formatted(), &Type_Char::Params_Formatted), + DispatchSingle(), + }; + const DispatchSingle* const call = DispatchSelect(&category, all_calls); + if (call) { + (this->*call->value)(args); return true; } return false; @@ -118,24 +126,20 @@ static const CallType Table_LessThan[] = { &Type_Char::Call_lessThan, }; - if (label.collection == Functions_Default) { - if (label.function_num < 0 || label.function_num >= 1) { + static DispatchTable all_tables[] = { + DispatchTable(Functions_Default, Table_Default), + DispatchTable(Functions_Equals, Table_Equals), + DispatchTable(Functions_LessThan, Table_LessThan), + DispatchTable(), + }; + const DispatchTable* const table = DispatchSelect(label.collection, all_tables); + if (table) { + if (label.function_num < 0 || label.function_num >= table->size) { FAIL() << "Bad function call " << label; + } else { + return (this->*table->table[label.function_num])(params, args); } - return (this->*Table_Default[label.function_num])(params, args); } - if (label.collection == Functions_Equals) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_Equals[label.function_num])(params, args); - } - if (label.collection == Functions_LessThan) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_LessThan[label.function_num])(params, args); - } return TypeInstance::Dispatch(self, label, params, args); } ReturnTuple Call_default(const ParamTuple& params, const ValueTuple& args); @@ -165,35 +169,21 @@ static const CallType Table_Formatted[] = { &Value_Char::Call_formatted, }; - if (label.collection == Functions_AsBool) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_AsBool[label.function_num])(self, params, args); - } - if (label.collection == Functions_AsChar) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_AsChar[label.function_num])(self, params, args); - } - if (label.collection == Functions_AsFloat) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_AsFloat[label.function_num])(self, params, args); - } - if (label.collection == Functions_AsInt) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_AsInt[label.function_num])(self, params, args); - } - if (label.collection == Functions_Formatted) { - if (label.function_num < 0 || label.function_num >= 1) { + static DispatchTable all_tables[] = { + DispatchTable(Functions_AsBool, Table_AsBool), + DispatchTable(Functions_AsChar, Table_AsChar), + DispatchTable(Functions_AsFloat, Table_AsFloat), + DispatchTable(Functions_AsInt, Table_AsInt), + DispatchTable(Functions_Formatted, Table_Formatted), + DispatchTable(), + }; + const DispatchTable* const table = DispatchSelect(label.collection, all_tables); + if (table) { + if (label.function_num < 0 || label.function_num >= table->size) { FAIL() << "Bad function call " << label; + } else { + return (this->*table->table[label.function_num])(self, params, args); } - return (this->*Table_Formatted[label.function_num])(self, params, args); } return TypeValue::Dispatch(self, label, params, args); } diff --git a/base/Category_Float.cpp b/base/Category_Float.cpp --- a/base/Category_Float.cpp +++ b/base/Category_Float.cpp @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 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. @@ -42,7 +42,6 @@ class Category_Float; class Type_Float; class Value_Float; -S CreateValue(Type_Float& parent, const ParamTuple& params, const ValueTuple& args); struct Category_Float : public TypeCategory { std::string CategoryName() const final { return "Float"; } Category_Float() { @@ -73,25 +72,34 @@ } return true; } + void Params_Float(std::vector>& args) const { + args = std::vector>{}; + } + void Params_AsBool(std::vector>& args) const { + args = std::vector>{}; + } + void Params_AsInt(std::vector>& args) const { + args = std::vector>{}; + } + void Params_AsFloat(std::vector>& args) const { + args = std::vector>{}; + } + void Params_Formatted(std::vector>& args) const { + args = std::vector>{}; + } bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { - if (&category == &GetCategory_Float()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_AsBool()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_AsInt()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_AsFloat()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_Formatted()) { - args = std::vector>{}; + using CallType = void(Type_Float::*)(std::vector>&)const; + static DispatchSingle all_calls[] = { + DispatchSingle(&GetCategory_AsBool(), &Type_Float::Params_AsBool), + DispatchSingle(&GetCategory_AsFloat(), &Type_Float::Params_AsFloat), + DispatchSingle(&GetCategory_AsInt(), &Type_Float::Params_AsInt), + DispatchSingle(&GetCategory_Float(), &Type_Float::Params_Float), + DispatchSingle(&GetCategory_Formatted(), &Type_Float::Params_Formatted), + DispatchSingle(), + }; + const DispatchSingle* const call = DispatchSelect(&category, all_calls); + if (call) { + (this->*call->value)(args); return true; } return false; @@ -113,24 +121,20 @@ static const CallType Table_LessThan[] = { &Type_Float::Call_lessThan, }; - if (label.collection == Functions_Default) { - if (label.function_num < 0 || label.function_num >= 1) { + static DispatchTable all_tables[] = { + DispatchTable(Functions_Default, Table_Default), + DispatchTable(Functions_Equals, Table_Equals), + DispatchTable(Functions_LessThan, Table_LessThan), + DispatchTable(), + }; + const DispatchTable* const table = DispatchSelect(label.collection, all_tables); + if (table) { + if (label.function_num < 0 || label.function_num >= table->size) { FAIL() << "Bad function call " << label; + } else { + return (this->*table->table[label.function_num])(params, args); } - return (this->*Table_Default[label.function_num])(params, args); } - if (label.collection == Functions_Equals) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_Equals[label.function_num])(params, args); - } - if (label.collection == Functions_LessThan) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_LessThan[label.function_num])(params, args); - } return TypeInstance::Dispatch(self, label, params, args); } ReturnTuple Call_default(const ParamTuple& params, const ValueTuple& args); @@ -157,29 +161,20 @@ static const CallType Table_Formatted[] = { &Value_Float::Call_formatted, }; - if (label.collection == Functions_AsBool) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_AsBool[label.function_num])(self, params, args); - } - if (label.collection == Functions_AsFloat) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_AsFloat[label.function_num])(self, params, args); - } - if (label.collection == Functions_AsInt) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_AsInt[label.function_num])(self, params, args); - } - if (label.collection == Functions_Formatted) { - if (label.function_num < 0 || label.function_num >= 1) { + static DispatchTable all_tables[] = { + DispatchTable(Functions_AsBool, Table_AsBool), + DispatchTable(Functions_AsFloat, Table_AsFloat), + DispatchTable(Functions_AsInt, Table_AsInt), + DispatchTable(Functions_Formatted, Table_Formatted), + DispatchTable(), + }; + const DispatchTable* const table = DispatchSelect(label.collection, all_tables); + if (table) { + if (label.function_num < 0 || label.function_num >= table->size) { FAIL() << "Bad function call " << label; + } else { + return (this->*table->table[label.function_num])(self, params, args); } - return (this->*Table_Formatted[label.function_num])(self, params, args); } return TypeValue::Dispatch(self, label, params, args); } diff --git a/base/Category_Int.cpp b/base/Category_Int.cpp --- a/base/Category_Int.cpp +++ b/base/Category_Int.cpp @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 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. @@ -43,7 +43,6 @@ class Category_Int; class Type_Int; class Value_Int; -S CreateValue(Type_Int& parent, const ParamTuple& params, const ValueTuple& args); struct Category_Int : public TypeCategory { std::string CategoryName() const final { return "Int"; } Category_Int() { @@ -74,29 +73,38 @@ } return true; } + void Params_Int(std::vector>& args) const { + args = std::vector>{}; + } + void Params_AsBool(std::vector>& args) const { + args = std::vector>{}; + } + void Params_AsChar(std::vector>& args) const { + args = std::vector>{}; + } + void Params_AsInt(std::vector>& args) const { + args = std::vector>{}; + } + void Params_AsFloat(std::vector>& args) const { + args = std::vector>{}; + } + void Params_Formatted(std::vector>& args) const { + args = std::vector>{}; + } bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { - if (&category == &GetCategory_Int()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_AsBool()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_AsChar()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_AsInt()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_AsFloat()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_Formatted()) { - args = std::vector>{}; + using CallType = void(Type_Int::*)(std::vector>&)const; + static DispatchSingle all_calls[] = { + DispatchSingle(&GetCategory_AsBool(), &Type_Int::Params_AsBool), + DispatchSingle(&GetCategory_AsChar(), &Type_Int::Params_AsChar), + DispatchSingle(&GetCategory_AsFloat(), &Type_Int::Params_AsFloat), + DispatchSingle(&GetCategory_AsInt(), &Type_Int::Params_AsInt), + DispatchSingle(&GetCategory_Formatted(), &Type_Int::Params_Formatted), + DispatchSingle(&GetCategory_Int(), &Type_Int::Params_Int), + DispatchSingle(), + }; + const DispatchSingle* const call = DispatchSelect(&category, all_calls); + if (call) { + (this->*call->value)(args); return true; } return false; @@ -118,24 +126,20 @@ static const CallType Table_LessThan[] = { &Type_Int::Call_lessThan, }; - if (label.collection == Functions_Default) { - if (label.function_num < 0 || label.function_num >= 1) { + static DispatchTable all_tables[] = { + DispatchTable(Functions_Default, Table_Default), + DispatchTable(Functions_Equals, Table_Equals), + DispatchTable(Functions_LessThan, Table_LessThan), + DispatchTable(), + }; + const DispatchTable* const table = DispatchSelect(label.collection, all_tables); + if (table) { + if (label.function_num < 0 || label.function_num >= table->size) { FAIL() << "Bad function call " << label; + } else { + return (this->*table->table[label.function_num])(params, args); } - return (this->*Table_Default[label.function_num])(params, args); } - if (label.collection == Functions_Equals) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_Equals[label.function_num])(params, args); - } - if (label.collection == Functions_LessThan) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_LessThan[label.function_num])(params, args); - } return TypeInstance::Dispatch(self, label, params, args); } ReturnTuple Call_default(const ParamTuple& params, const ValueTuple& args); @@ -165,35 +169,21 @@ static const CallType Table_Formatted[] = { &Value_Int::Call_formatted, }; - if (label.collection == Functions_AsBool) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_AsBool[label.function_num])(self, params, args); - } - if (label.collection == Functions_AsChar) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_AsChar[label.function_num])(self, params, args); - } - if (label.collection == Functions_AsFloat) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_AsFloat[label.function_num])(self, params, args); - } - if (label.collection == Functions_AsInt) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_AsInt[label.function_num])(self, params, args); - } - if (label.collection == Functions_Formatted) { - if (label.function_num < 0 || label.function_num >= 1) { + static DispatchTable all_tables[] = { + DispatchTable(Functions_AsBool, Table_AsBool), + DispatchTable(Functions_AsChar, Table_AsChar), + DispatchTable(Functions_AsFloat, Table_AsFloat), + DispatchTable(Functions_AsInt, Table_AsInt), + DispatchTable(Functions_Formatted, Table_Formatted), + DispatchTable(), + }; + const DispatchTable* const table = DispatchSelect(label.collection, all_tables); + if (table) { + if (label.function_num < 0 || label.function_num >= table->size) { FAIL() << "Bad function call " << label; + } else { + return (this->*table->table[label.function_num])(self, params, args); } - return (this->*Table_Formatted[label.function_num])(self, params, args); } return TypeValue::Dispatch(self, label, params, args); } diff --git a/base/Category_String.cpp b/base/Category_String.cpp --- a/base/Category_String.cpp +++ b/base/Category_String.cpp @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 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. @@ -31,6 +31,8 @@ #include "Category_Append.hpp" #include "Category_Build.hpp" #include "Category_Default.hpp" +#include "Category_DefaultOrder.hpp" +#include "Category_Order.hpp" #include "Category_Equals.hpp" #include "Category_LessThan.hpp" @@ -48,7 +50,6 @@ class Category_String; class Type_String; class Value_String; -S CreateValue(Type_String& parent, const ParamTuple& params, const ValueTuple& args); struct Category_String : public TypeCategory { std::string CategoryName() const final { return "String"; } Category_String() { @@ -79,21 +80,38 @@ } return true; } + void Params_String(std::vector>& args) const { + args = std::vector>{}; + } + void Params_AsBool(std::vector>& args) const { + args = std::vector>{}; + } + void Params_Formatted(std::vector>& args) const { + args = std::vector>{}; + } + void Params_ReadAt(std::vector>& args) const { + args = std::vector>{GetType_Char(T_get())}; + } + void Params_SubSequence(std::vector>& args) const { + args = std::vector>{}; + } + void Params_DefaultOrder(std::vector>& args) const { + args = std::vector>{GetType_Char(T_get())}; + } bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { - if (&category == &GetCategory_String()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_AsBool()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_Formatted()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_ReadAt()) { - args = std::vector>{GetType_Char(T_get())}; + using CallType = void(Type_String::*)(std::vector>&)const; + static DispatchSingle all_calls[] = { + DispatchSingle(&GetCategory_String(), &Type_String::Params_String), + DispatchSingle(&GetCategory_AsBool(), &Type_String::Params_AsBool), + DispatchSingle(&GetCategory_Formatted(), &Type_String::Params_Formatted), + DispatchSingle(&GetCategory_ReadAt(), &Type_String::Params_ReadAt), + DispatchSingle(&GetCategory_SubSequence(), &Type_String::Params_SubSequence), + DispatchSingle(&GetCategory_DefaultOrder(), &Type_String::Params_DefaultOrder), + DispatchSingle(), + }; + const DispatchSingle* const call = DispatchSelect(&category, all_calls); + if (call) { + (this->*call->value)(args); return true; } return false; @@ -118,30 +136,21 @@ static const CallType Table_String[] = { &Type_String::Call_builder, }; - if (label.collection == Functions_Default) { - if (label.function_num < 0 || label.function_num >= 1) { + static DispatchTable all_tables[] = { + DispatchTable(Functions_Default, Table_Default), + DispatchTable(Functions_Equals, Table_Equals), + DispatchTable(Functions_LessThan, Table_LessThan), + DispatchTable(Functions_String, Table_String), + DispatchTable(), + }; + const DispatchTable* const table = DispatchSelect(label.collection, all_tables); + if (table) { + if (label.function_num < 0 || label.function_num >= table->size) { FAIL() << "Bad function call " << label; + } else { + return (this->*table->table[label.function_num])(params, args); } - return (this->*Table_Default[label.function_num])(params, args); } - if (label.collection == Functions_Equals) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_Equals[label.function_num])(params, args); - } - if (label.collection == Functions_LessThan) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_LessThan[label.function_num])(params, args); - } - if (label.collection == Functions_String) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_String[label.function_num])(params, args); - } return TypeInstance::Dispatch(self, label, params, args); } ReturnTuple Call_default(const ParamTuple& params, const ValueTuple& args); @@ -160,6 +169,9 @@ static const CallType Table_AsBool[] = { &Value_String::Call_asBool, }; + static const CallType Table_DefaultOrder[] = { + &Value_String::Call_defaultOrder, + }; static const CallType Table_Formatted[] = { &Value_String::Call_formatted, }; @@ -175,48 +187,31 @@ static const CallType Table_SubSequence[] = { &Value_String::Call_subSequence, }; - if (label.collection == Functions_AsBool) { - if (label.function_num < 0 || label.function_num >= 1) { + static DispatchTable all_tables[] = { + DispatchTable(Functions_AsBool, Table_AsBool), + DispatchTable(Functions_Container, Table_Container), + DispatchTable(Functions_DefaultOrder, Table_DefaultOrder), + DispatchTable(Functions_Formatted, Table_Formatted), + DispatchTable(Functions_ReadAt, Table_ReadAt), + DispatchTable(Functions_String, Table_String), + DispatchTable(Functions_SubSequence, Table_SubSequence), + DispatchTable(), + }; + const DispatchTable* const table = DispatchSelect(label.collection, all_tables); + if (table) { + if (label.function_num < 0 || label.function_num >= table->size) { FAIL() << "Bad function call " << label; + } else { + return (this->*table->table[label.function_num])(self, params, args); } - return (this->*Table_AsBool[label.function_num])(self, params, args); } - if (label.collection == Functions_Formatted) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_Formatted[label.function_num])(self, params, args); - } - if (label.collection == Functions_ReadAt) { - if (label.function_num < 0 || label.function_num >= 2) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_ReadAt[label.function_num])(self, params, args); - } - if (label.collection == Functions_Container) { - if (label.function_num < 0 || label.function_num >= 2) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_Container[label.function_num])(self, params, args); - } - if (label.collection == Functions_String) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_String[label.function_num])(self, params, args); - } - if (label.collection == Functions_SubSequence) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_SubSequence[label.function_num])(self, params, args); - } return TypeValue::Dispatch(self, label, params, args); } std::string CategoryName() const final { return parent->CategoryName(); } const PrimString& AsString() const final { return value_; } ReturnTuple Call_asBool(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_formatted(const S& Var_self, const ParamTuple& params, const ValueTuple& args); + ReturnTuple Call_defaultOrder(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_readAt(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_size(const S& Var_self, const ParamTuple& params, const ValueTuple& args); ReturnTuple Call_subSequence(const S& Var_self, const ParamTuple& params, const ValueTuple& args); @@ -256,6 +251,28 @@ std::ostringstream output_; }; +struct StringOrder : public AnonymousOrder { + StringOrder(S container, const std::string& s) + : AnonymousOrder(container, Function_Order_next, Function_Order_get), value(s) {} + + S Call_next(const S& self) final { + if (index+1 >= value.size()) { + return Var_empty; + } else { + ++index; + return self; + } + } + + S Call_get(const S& self) final { + if (index >= value.size()) FAIL() << "iterated past end of String"; + return Box_Char(value[index]); + } + + const std::string& value; + int index = 0; +}; + ReturnTuple Type_String::Call_default(const ParamTuple& params, const ValueTuple& args) { TRACE_FUNCTION("String.default") return ReturnTuple(Box_String("")); @@ -283,6 +300,14 @@ ReturnTuple Value_String::Call_formatted(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { TRACE_FUNCTION("String.formatted") return ReturnTuple(Var_self); +} +ReturnTuple Value_String::Call_defaultOrder(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("String.defaultOrder") + if (value_.empty()) { + return ReturnTuple(Var_empty); + } else { + return ReturnTuple(S_get(new StringOrder(Var_self, value_))); + } } ReturnTuple Value_String::Call_readAt(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { TRACE_FUNCTION("String.readAt") diff --git a/base/builtin.0rp b/base/builtin.0rp --- a/base/builtin.0rp +++ b/base/builtin.0rp @@ -93,6 +93,7 @@ // Literals: Quote Char sequence with ". concrete String { refines AsBool + refines DefaultOrder refines Formatted refines ReadAt refines SubSequence @@ -155,6 +156,36 @@ @value interface Build<|#x> { // Build and return a value from the current state. build () -> (#x) +} + +// Ordered data, primarily used for the traverse built-in. +// +// Example: +// +// traverse (someIntOrder -> Int i) { +// // code that uses index i +// } +@value interface Order<|#x> { + // Returns an updated instance, or empty if the end was reached. + // + // Notes: + // - This can return either a mutated self or a new copy. The caller should + // assume that next() will mutate the instance. + // - This should not generally be used directly; use the traverse built-in. + next () -> (optional #self) + + // Returns the value at the current position. + get () -> (#x) +} + +// Provides a default Order for a container. +// +// Notes: +// - The return value is primarily intended for use with the traverse built-in. +// - Also see the documentation for Order and traverse. +@value interface DefaultOrder<|#x> { + // Returns the default Order for the container. + defaultOrder () -> (optional Order<#x>) } // Contains a flexible number of values of some type. diff --git a/base/category-header.hpp b/base/category-header.hpp --- a/base/category-header.hpp +++ b/base/category-header.hpp @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 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. @@ -30,9 +30,5 @@ class CategoryFunction; class TypeFunction; class ValueFunction; - -#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 @@ -269,3 +269,24 @@ bool TypeValue::Present() const { return true; } + +AnonymousOrder::AnonymousOrder(const S cont, + const ValueFunction& func_next, + const ValueFunction& func_get) + : container(cont), function_next(func_next), function_get(func_get) {} + +std::string AnonymousOrder::CategoryName() const { return "AnonymousOrder"; } + +ReturnTuple AnonymousOrder::Dispatch( + const S& self, const ValueFunction& label, + const ParamTuple& params, const ValueTuple& args) { + if (&label == &function_next) { + TRACE_FUNCTION("AnonymousOrder.next") + return ReturnTuple(Call_next(self)); + } + if (&label == &function_get) { + TRACE_FUNCTION("AnonymousOrder.get") + return ReturnTuple(Call_get(self)); + } + return TypeValue::Dispatch(self, label, params, args); +} 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 #include // For occasional debugging output in generated code. #include #include @@ -214,5 +215,77 @@ std::mutex mutex_; std::map::Type, S> cache_; }; + +class AnonymousOrder : public TypeValue { + protected: + // Passing in the function labels allows linking without depending on Order + // when this class isn't used anywhere. + AnonymousOrder(const S cont, + const ValueFunction& func_next, + const ValueFunction& func_get); + + std::string CategoryName() const final; + ReturnTuple Dispatch(const S& self, + const ValueFunction& label, + const ParamTuple& params, + const ValueTuple& args) final; + + virtual ~AnonymousOrder() = default; + + private: + virtual S Call_next(const S& self) = 0; + virtual S Call_get(const S& self) = 0; + + const S container; + const ValueFunction& function_next; + const ValueFunction& function_get; +}; + +template +struct DispatchTable { + constexpr DispatchTable() : key(nullptr), table(nullptr), size(0) {} + + template + DispatchTable(const void* k, const F(&t)[S]) : key(k), table(t), size(S) {} + + bool operator < (const DispatchTable& other) const { return key < other.key; } + + const void* key; + const F* table; + int size; +}; + +template +struct DispatchSingle { + constexpr DispatchSingle() : key(nullptr), value() {} + + DispatchSingle(const void* k, const F v) : key(k), value(v) {} + + bool operator < (const DispatchSingle& other) const { return key < other.key; } + + const void* key; + F value; + int size; +}; + +template +const T* DispatchSelect(const void* key, T(&table)[S]) { + if (S < 2) return nullptr; + if (table[0].key != nullptr) { + std::sort(table, table+S); + } + int i = 1, j = S; + while (j-i > 1) { + const int k = (i+j)/2; + if (table[k].key < key) { + i = k; + } else if (table[k].key > key) { + j = k; + } else { + return &table[k]; + } + } + return (table[i].key == key)? &table[i] : nullptr; +} #endif // CATEGORY_SOURCE_HPP_ diff --git a/base/logging.cpp b/base/logging.cpp --- a/base/logging.cpp +++ b/base/logging.cpp @@ -19,7 +19,9 @@ #include "logging.hpp" #include +#include #include +#include #include @@ -116,6 +118,7 @@ void SourceContext::SetLocal(const char* at) { at_ = at; + LogCalls::MaybeLogCall(name_, at_); } void SourceContext::AppendTrace(TraceList& trace) const { @@ -177,4 +180,55 @@ const std::vector& ProgramArgv::GetArgs() const { return argv_; +} + +std::string FixCsvString(const char* string) { + std::string fixed; + while (*string) { + switch (*string) { + case '\\': + break; + case '"': + fixed.push_back('\''); + break; + default: + fixed.push_back(*string); + break; + } + ++string; + } + return fixed; +} + +unsigned int UniqueId() { + const auto time = std::chrono::steady_clock::now().time_since_epoch(); + return (1000000009 * std::chrono::duration_cast(time).count()); +} + +LogCallsToFile::LogCallsToFile(std::string filename) + : unique_id_(UniqueId()), + filename_(std::move(filename)), + log_file_(filename_.empty()? + nullptr : + new std::fstream(filename_, std::ios::in | + std::ios::out | + std::ios::ate | + std::ios::app)), + cross_and_capture_to_(this) { + if (log_file_) { + if (!*log_file_) { + FAIL() << "Failed to open call log " << filename_ << " for writing"; + } + } +} + +void LogCallsToFile::LogCall(const char* name, const char* at) { + if (log_file_) { + std::lock_guard lock(mutex_); + const auto time = std::chrono::steady_clock::now().time_since_epoch(); + *log_file_ << std::chrono::duration_cast(time).count() << "," + << unique_id_ << "," + << "\"" << FixCsvString(name) << "\"" << "," + << "\"" << FixCsvString(at) << "\"" << std::endl; + } } diff --git a/base/logging.hpp b/base/logging.hpp --- a/base/logging.hpp +++ b/base/logging.hpp @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 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. @@ -20,7 +20,10 @@ #define LOGGING_HPP_ #include +#include #include +#include +#include #include #include #include @@ -78,11 +81,11 @@ #define PRED_CONTEXT_POINT(point) \ TraceContext::SetContext(point), - #define CAPTURE_CREATION \ - CreationTrace creation_context_; + #define CAPTURE_CREATION(name) \ + CreationTrace creation_context_ = name; #define TRACE_CREATION \ - TraceCreation trace_creation(TypeInstance::TypeName(parent), creation_context_); + TraceCreation trace_creation(creation_context_); #define FAIL_WHEN_NULL(value) \ FailWhenNull(value) @@ -171,35 +174,43 @@ class ProgramArgv : public Argv { public: inline ProgramArgv(int argc, const char** argv) - : argv_(argv, argv + argc), capture_to_(this) {} + : argv_(argv, argv + argc), cross_and_capture_to_(this) {} private: const std::vector& GetArgs() const final; const std::vector argv_; - const ScopedCapture capture_to_; + const AutoThreadCrosser cross_and_capture_to_; }; class CreationTrace { public: - inline CreationTrace() : trace_(TraceContext::GetTrace()) {} + // NOTE: Using a template with [] here breaks inline member initialization + // when using CAPTURE_CREATION in g++. + inline CreationTrace(const char* type) + : type_(type), trace_(TraceContext::GetTrace()) {} + inline std::string GetType() const { + return type_; + } + inline const TraceList& GetTrace() const { return trace_; } private: + const char* const type_; const TraceList trace_; }; class TraceCreation : public capture_thread::ThreadCapture { public: - inline TraceCreation(std::string type, const CreationTrace& trace) - : type_(type), trace_(trace), capture_to_(this) {} + inline TraceCreation(const CreationTrace& trace) + : trace_(trace), capture_to_(this) {} static inline std::string GetType() { if (GetCurrent()) { - return GetCurrent()->type_; + return GetCurrent()->trace_.GetType(); } else { return std::string(); } @@ -214,10 +225,37 @@ } private: - - const std::string type_; const CreationTrace& trace_; const ScopedCapture capture_to_; +}; + +class LogCalls : public capture_thread::ThreadCapture { + public: + static inline void MaybeLogCall(const char* name, const char* at) { + if (GetCurrent()) { + GetCurrent()->LogCall(name, at); + } + } + + protected: + virtual ~LogCalls() = default; + + private: + virtual void LogCall(const char* name, const char* at) = 0; +}; + +class LogCallsToFile : public LogCalls { + public: + LogCallsToFile(std::string filename); + + private: + void LogCall(const char* name, const char* at) final; + + std::mutex mutex_; + const unsigned int unique_id_; + const std::string& filename_; + const std::unique_ptr log_file_; + const AutoThreadCrosser cross_and_capture_to_; }; #endif // LOGGING_HPP_ 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 @@ -9,20 +9,16 @@ } String message <- "Failed to match \"" + match + "\" at " + contextOld.getPosition() ParseContext context <- contextOld - scoped { - Int index <- 0 - } in while (index < match.size()) { - $ReadOnly[context,index]$ + traverse (Counter.zeroIndexed(match.size()) -> Int index) { + $ReadOnly[index]$ if (context.atEof() || context.current() != match.readAt(index)) { if (index > 0) { // 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)) @@ -49,27 +45,32 @@ contextOld.getPosition() ParseContext context <- contextOld [Append&Build] builder <- String.builder() + + optional Order counter <- empty + if (max == 0) { + counter <- Counter.unlimited() + } else { + counter <- Counter.zeroIndexed(max) + } + Int count <- 0 - while (!context.atEof() && (max == 0 || count < max)) { - $ReadOnly[context,count]$ + traverse (counter -> count) { + $Hidden[count,counter]$ + if (context.atEof()) { + break + } Bool found <- false - scoped { - Int index <- 0 - } in while (index < matches.size()) { - $ReadOnly[index]$ + traverse (Counter.zeroIndexed(matches.size()) -> Int index) { + $ReadOnly[context,index]$ if (context.current() == matches.readAt(index)) { \ builder.append(matches.readAt(index).formatted()) found <- true break } - } update { - index <- index+1 } if (!found) { break } - } update { - count <- count+1 context <- context.advance() } if (count >= min) { @@ -78,7 +79,7 @@ // Partial match => set error context. return context.setBrokenInput(message) } else { - return context.setValue(ErrorOr:error(message)) + return context.setValue(ErrorOr:error(message)) } } @@ -98,7 +99,7 @@ } 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)) } @@ -137,7 +138,7 @@ @value Formatted message run (contextOld) { - return contextOld.setValue(ErrorOr:error(message)) + return contextOld.setValue(ErrorOr:error(message)) } create (message) { @@ -160,7 +161,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() } @@ -216,7 +217,7 @@ if (context.hasAnyError()) { return context.toState() } else { - ParseContext context2 <- context.run(parser2) + ParseContext context2 <- context.run(parser2) if (context2.hasAnyError()) { return context2.convertError() } else { @@ -244,7 +245,7 @@ if (contextOld.hasAnyError()) { return contextOld.convertError() } - ParseContext context <- contextOld.run(parser1) + ParseContext context <- contextOld.run(parser1) if (context.hasAnyError()) { return context.convertError() } else { 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 @@ -23,6 +23,25 @@ } define TestDataParser { + // Mark @category members as read-only, to avoid accidental assignment. + $ReadOnly[sentenceOrToken, + acronymOrAardvark, + fileStart, + fileEnd, + nameTag, + descriptionTag, + aWordTag]$ + + // Mark @category members as hidden, since they should not be used directly. + $Hidden[whitespace, + sentenceChars, + sentence, + quote, + quotedSentence, + token, + acronym, + aardvark]$ + refines Parser @category Parser whitespace <- SequenceOfParser.create(" \n\t",1,0) `Parse.or` Parse.error("Expected whitespace") diff --git a/example/primes/.zeolite-module b/example/primes/.zeolite-module new file mode 100644 --- /dev/null +++ b/example/primes/.zeolite-module @@ -0,0 +1,11 @@ +root: "../.." +path: "example/primes" +private_deps: [ + "lib/container" + "lib/thread" + "lib/util" +] +mode: binary { + category: PrimesDemo + function: run +} diff --git a/example/primes/README.md b/example/primes/README.md new file mode 100644 --- /dev/null +++ b/example/primes/README.md @@ -0,0 +1,57 @@ +# Zeolite Primes Example + +*Also see +[a highlighted version of the example code](https://ta0kira.github.io/zeolite/example/primes).* + +This example demonstrates synchronizing two threads using `lib/thread`. + +## Notes + +There are two threads in this program: + +1. The main thread, which deals with user input. +2. The computation thread, which is controlled by the main thread. + +When the program starts, the computation thread is stopped, and the main thread +is waiting for user input. Follow the prompts to start, stop, and cancel the +computation thread. The program will print the prime numbers computed during the +time that the computation thread was running. + +A few specific points about the example: + +- See `flag.0rx` for an example of how `ConditionWait` and `ConditionResume` + (from `lib/thread`) can be used to start and stop a thread process. (Also + notice that it uses the type intersection `[ConditionWait&ConditionResume]`.) + +- `prime-tracker.0rx` uses both the `$ReadOnly[...]$` and `$Hidden[...]$` + pragmas to cut down on possible errors when multiple variables of the same + type are in scope. + +- Other than the condition logic in `ThreadFlag`, the other categories in this + example *are not* thread-safe. On the other hand, the main thread does not + read or modify any shared state other than the `ThreadFlag` while the + computation thread is running. Other approaches might require using `Mutex`es + in other places. + +## Running + +This example depends on the optional `lib/thread` library. That library is +included in the base package, but you might need to build it first. + +```shell +ZEOLITE_PATH=$(zeolite --get-path) +zeolite -p "$ZEOLITE_PATH" -r lib/thread +``` + +To run the example: + +```shell +# This is just to locate the example code. Not for normal use! +ZEOLITE_PATH=$(zeolite --get-path) + +# Compile the example. +zeolite -p "$ZEOLITE_PATH" -r example/primes + +# Execute the compiled binary. +$ZEOLITE_PATH/example/primes/PrimesDemo +``` diff --git a/example/primes/flag.0rp b/example/primes/flag.0rp new file mode 100644 --- /dev/null +++ b/example/primes/flag.0rp @@ -0,0 +1,32 @@ +$ModuleOnly$ + +// A gate for starting, stopping, and canceling thread processes. +@value interface ThreadGate { + // Start the thread(s). + start () -> (#self) + + // Stop the thread(s). + stop () -> (#self) + + // Returns true iff the thread(s) should be running. + getEnabled () -> (Bool) + + // Permanently cancel the thread(s). + cancel () -> (#self) +} + + +// Determine if a thread should continue or exit. +@value interface ThreadContinue { + // Blocks until a start or cancel signal is received. If false is returned, + // the thread should clean up and exit. + shouldContinue () -> (Bool) +} + +// Implementation of thread gating with a flag. +concrete ThreadFlag { + refines ThreadGate + refines ThreadContinue + + @type new () -> (ThreadFlag) +} diff --git a/example/primes/flag.0rx b/example/primes/flag.0rx new file mode 100644 --- /dev/null +++ b/example/primes/flag.0rx @@ -0,0 +1,64 @@ +define ThreadFlag { + @value [ConditionWait&ConditionResume] cond + @value Bool enabled + @value Bool canceled + + new () { + return ThreadFlag{ ThreadCondition.new(), false, false } + } + + start () { + scoped { + MutexLock lock <- MutexLock.lock(cond) + } cleanup { + \ lock.freeResource() + } in enabled <- true + \ cond.resumeAll() + return self + } + + stop () { + scoped { + MutexLock lock <- MutexLock.lock(cond) + } cleanup { + \ lock.freeResource() + } in enabled <- false + return self + } + + getEnabled () { + scoped { + MutexLock lock <- MutexLock.lock(cond) + } cleanup { + \ lock.freeResource() + } in return enabled && !canceled + } + + cancel () { + scoped { + MutexLock lock <- MutexLock.lock(cond) + } cleanup { + \ lock.freeResource() + } in canceled <- true + \ cond.resumeAll() + return self + } + + shouldContinue () { + scoped { + MutexLock lock <- MutexLock.lock(cond) + } cleanup { + \ lock.freeResource() + } in while (true) { + if (canceled) { + return false + } elif (enabled) { + break + } else { + // The Mutex associated with cond is unlocked during wait(). + \ cond.wait() + } + } + return true + } +} diff --git a/example/primes/prime-thread.0rp b/example/primes/prime-thread.0rp new file mode 100644 --- /dev/null +++ b/example/primes/prime-thread.0rp @@ -0,0 +1,8 @@ +$ModuleOnly$ + +// Repeatedly checks the next possible prime until canceled. +concrete PrimeThread { + refines Routine + + @type create (ThreadContinue,PrimeTracker) -> (PrimeThread) +} diff --git a/example/primes/prime-thread.0rx b/example/primes/prime-thread.0rx new file mode 100644 --- /dev/null +++ b/example/primes/prime-thread.0rx @@ -0,0 +1,14 @@ +define PrimeThread { + @value ThreadContinue flag + @value PrimeTracker tracker + + create (flag,tracker) { + return PrimeThread{ flag, tracker } + } + + run () { + while (flag.shouldContinue()) { + \ tracker.checkNextPossible(flag) + } + } +} diff --git a/example/primes/prime-tracker.0rp b/example/primes/prime-tracker.0rp new file mode 100644 --- /dev/null +++ b/example/primes/prime-tracker.0rp @@ -0,0 +1,9 @@ +$ModuleOnly$ + +// Incrementally tracks primes. +concrete PrimeTracker { + @type create () -> (PrimeTracker) + @value checkNextPossible (ThreadContinue) -> (#self) + // optional Order can be used with the traverse built-in for iteration. + @value getResults () -> (optional Order) +} diff --git a/example/primes/prime-tracker.0rx b/example/primes/prime-tracker.0rx new file mode 100644 --- /dev/null +++ b/example/primes/prime-tracker.0rx @@ -0,0 +1,46 @@ +define PrimeTracker { + @value Vector primes + @value Int nextPossible + + create () { + return PrimeTracker{ Vector:create(), 2 } + } + + checkNextPossible (flag) { + Int toCheck <- nextPossible + $ReadOnly[toCheck]$ + + Bool isPrime <- true + + traverse (getResults() -> Int prime) { + $ReadOnly[prime]$ + $Hidden[nextPossible]$ + if (!flag.shouldContinue()) { + return self + } + if (toCheck%prime == 0) { + isPrime <- false + break + } + if (prime*prime >= toCheck) { + break + } + } + // Postpone updating the next possible until we know that there wasn't an + // early return due to the flag. + nextPossible <- nextPossible+1 + + if (isPrime) { + \ LazyStream.new() + .append("\r") + .append(toCheck) + .writeTo(SimpleOutput.stderr()) + \ primes.push(toCheck) + } + return self + } + + getResults () { + return primes.defaultOrder() + } +} diff --git a/example/primes/primes-demo.0rx b/example/primes/primes-demo.0rx new file mode 100644 --- /dev/null +++ b/example/primes/primes-demo.0rx @@ -0,0 +1,62 @@ +concrete PrimesDemo { + @type run () -> () +} + +define PrimesDemo { + run () { + PrimeTracker tracker <- PrimeTracker.create() + ThreadFlag flag <- ThreadFlag.new() + Thread thread <- ProcessThread.from(PrimeThread.create(flag,tracker)).start() + + // Interactive input loop. + + scoped { + TextReader reader <- TextReader.fromBlockReader(SimpleInput.stdin()) + } in while (!reader.pastEnd()) { + $Hidden[tracker,thread]$ + + \ LazyStream.new() + .append("Press [Enter] to toggle start/stop computation thread. Type \"exit\" to exit.\n") + .writeTo(SimpleOutput.stderr()) + String input <- reader.readNextLine() + if (reader.pastEnd()) { + break + } + + if (input == "") { + if (flag.getEnabled()) { + \ flag.stop() + \ LazyStream.new() + .append("Stopped.\n") + .writeTo(SimpleOutput.stderr()) + } else { + \ flag.start() + \ LazyStream.new() + .append("Started.\n") + .writeTo(SimpleOutput.stderr()) + } + } elif (input == "exit") { + break + } else { + \ LazyStream.new() + .append("Please try again!\n") + .writeTo(SimpleOutput.stderr()) + } + } + + // Wait for the thread to exit, then print the results. + + \ flag.cancel() + \ LazyStream.new() + .append("Exiting.\n") + .writeTo(SimpleOutput.stderr()) + \ thread.join() + + traverse (tracker.getResults() -> Int prime) { + \ LazyStream.new() + .append(prime) + .append("\n") + .writeTo(SimpleOutput.stdout()) + } + } +} diff --git a/lib/container/interfaces.0rp b/lib/container/interfaces.0rp --- a/lib/container/interfaces.0rp +++ b/lib/container/interfaces.0rp @@ -50,3 +50,16 @@ // Returns the value associated with the key if present. get (#k) -> (optional #v) } + +// A single key-value pair from a KVReader. +@value interface KeyValue<|#k,#v> { + // Get the key. + // + // Notes: + // - Calling mutating functions on the key could invalidate the structure of + // the KVReader. + getKey () -> (#k) + + // Get the value. + getValue () -> (#v) +} diff --git a/lib/container/search-tree.0rp b/lib/container/search-tree.0rp --- a/lib/container/search-tree.0rp +++ b/lib/container/search-tree.0rp @@ -22,12 +22,30 @@ // - #k: The key type. // - #v: The value type. concrete SearchTree<#k,#v> { + refines DefaultOrder> refines KVWriter<#k,#v> refines KVReader<#k,#v> #k defines LessThan<#k> // Create an empty tree. @type new () -> (#self) + + // Traverse the tree in the reverse order of defaultOrder(). + // + // Notes: + // - Traversal of the entire tree is amortized O(n); however, the cost of any + // particular iteration could be up to O(log n). + // - The overall memory cost is O(log n). + @value reverseOrder () -> (optional Order>) + + // Traverse in the default order. + // + // Notes: + // - This is from DefaultOrder, but is made explicit for documentation. + // - Traversal of the entire tree is amortized O(n); however, the cost of any + // particular iteration could be up to O(log n). + // - The overall memory cost is O(log n). + @value defaultOrder () -> (optional Order>) } // A validated binary search tree for key-value storage. @@ -40,7 +58,7 @@ // - This is the same as SearchTree, but it validates the tree structure every // time there is a modification, which is extremely inefficient. This should // therefore only be used in tests. -concrete ValidatedTree<#k,#v> { +concrete ValidatedTree<#k|#v|> { refines KVWriter<#k,#v> refines KVReader<#k,#v> #k defines LessThan<#k> diff --git a/lib/container/search-tree.0rt b/lib/container/search-tree.0rt --- a/lib/container/search-tree.0rt +++ b/lib/container/search-tree.0rt @@ -16,11 +16,11 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] -testcase "integration test" { +testcase "SearchTree tests" { success } -unittest test { +unittest integrationTest { [KVWriter&KVReader] tree <- ValidatedTree.new() Int count <- 30 @@ -61,4 +61,48 @@ } update { i <- i+1 } +} + +unittest defaultOrder { + SearchTree tree <- SearchTree.new() + Int hash <- 13 + Int max <- 20 + $ReadOnly[hash,max]$ + + // Populate the tree in a pseudo-random order. + traverse (Counter.zeroIndexed(max) -> Int i) { + \ ((i*hash)%max) `tree.set` i + } + + // Validate the traversal order. + Int index <- 0 + traverse (tree.defaultOrder() -> KeyValue entry) { + \ Testing.checkEquals(entry.getKey(),index) + \ Testing.checkEquals((entry.getValue()*hash)%max,entry.getKey()) + index <- index+1 + } + + \ Testing.checkEquals(index,20) +} + +unittest reverseOrder { + SearchTree tree <- SearchTree.new() + Int hash <- 13 + Int max <- 20 + $ReadOnly[hash,max]$ + + // Populate the tree in a pseudo-random order. + traverse (Counter.zeroIndexed(max) -> Int i) { + \ ((i*hash)%max) `tree.set` i + } + + // Validate the traversal order. + Int index <- 20 + traverse (tree.reverseOrder() -> KeyValue entry) { + index <- index-1 + \ Testing.checkEquals(entry.getKey(),index) + \ Testing.checkEquals((entry.getValue()*hash)%max,entry.getKey()) + } + + \ Testing.checkEquals(index,0) } diff --git a/lib/container/search-tree.0rx b/lib/container/search-tree.0rx --- a/lib/container/search-tree.0rx +++ b/lib/container/search-tree.0rx @@ -36,6 +36,14 @@ get (k) { return Node<#k,#v>.find(root,k) } + + defaultOrder () { + return ForwardTreeOrder:create(root) + } + + reverseOrder () { + return ReverseTreeOrder:create(root) + } } define ValidatedTree { @@ -69,6 +77,11 @@ @type delete (optional Node<#k,#v>,#k) -> (optional Node<#k,#v>) @type find (optional Node<#k,#v>,#k) -> (optional #v) @type validate (optional Node<#k,#v>) -> () + + @value getLower () -> (optional Node<#k,#v>) + @value getHigher () -> (optional Node<#k,#v>) + @value getKey () -> (#k) + @value getValue () -> (#v) } define Node { @@ -134,6 +147,14 @@ } } + getLower () { return lower } + + getHigher () { return higher } + + getKey () { return key } + + getValue () { return value } + @value validateOrder () -> () validateOrder () { if (present(lower)) { @@ -303,29 +324,121 @@ @value getHeight () -> (Int) getHeight () { return height } - // It is unsafe to change the key after construction, so there is no setter. - // - // Unlike other languages, a member is only accessible by the value that owns - // it. More specifically, @type functions in Node can only access @value - // members via explicit @value getters and setters. - @value getKey () -> (#k) - getKey () { return key } - - @value getValue () -> (#v) - getValue () { return value } - @value setValue (#v) -> () setValue (v) { value <- v } - @value getLower () -> (optional Node<#k,#v>) - getLower () { return lower } - @value setLower (optional Node<#k,#v>) -> () setLower (l) { lower <- l } - @value getHigher () -> (optional Node<#k,#v>) - getHigher () { return higher } - @value setHigher (optional Node<#k,#v>) -> () setHigher (h) { higher <- h } +} + +concrete TreeKeyValue<#k,#v> { + refines KeyValue<#k,#v> + + @category create<#k,#v> (#k,#v) -> (TreeKeyValue<#k,#v>) +} + +define TreeKeyValue { + @value #k key + @value #v value + + create (key,value) { + return TreeKeyValue<#k,#v>{ key, value } + } + + getKey () { + return key + } + + getValue () { + return value + } +} + +concrete ForwardTreeOrder<#k,#v> { + refines Order> + #k defines LessThan<#k> + + @category create<#k,#v> + #k defines LessThan<#k> + (optional Node<#k,#v>) -> (optional ForwardTreeOrder<#k,#v>) +} + +define ForwardTreeOrder { + $ReadOnly[node,prev]$ + + @value Node<#k,#v> node + @value optional ForwardTreeOrder<#k,#v> prev + + create (node) { + optional Node<#k,#v> node2 <- node + optional ForwardTreeOrder<#k,#v> current <- empty + while (present(node2)) { + current <- ForwardTreeOrder<#k,#v>{ require(node2), current } + node2 <- require(node2).getLower() + } + return current + } + + next () { + // Algorithm: + // 1. Pop self from the stack. + // 2. Traverse lower to the bottom starting from the higher child of self. + optional Node<#k,#v> node2 <- node.getHigher() + optional ForwardTreeOrder<#k,#v> current <- prev + while (present(node2)) { + current <- ForwardTreeOrder<#k,#v>{ require(node2), current } + node2 <- require(node2).getLower() + } + return current + } + + get () { + return TreeKeyValue:create(node.getKey(),node.getValue()) + } +} + +concrete ReverseTreeOrder<#k,#v> { + refines Order> + #k defines LessThan<#k> + + @category create<#k,#v> + #k defines LessThan<#k> + (optional Node<#k,#v>) -> (optional ReverseTreeOrder<#k,#v>) +} + +define ReverseTreeOrder { + $ReadOnly[node,prev]$ + + @value Node<#k,#v> node + @value optional ReverseTreeOrder<#k,#v> prev + + create (node) { + optional Node<#k,#v> node2 <- node + optional ReverseTreeOrder<#k,#v> current <- empty + while (present(node2)) { + current <- ReverseTreeOrder<#k,#v>{ require(node2), current } + node2 <- require(node2).getHigher() + } + return current + } + + next () { + // Algorithm: + // 1. Pop self from the stack. + // 2. Traverse higher to the bottom starting from the lower child of self. + optional Node<#k,#v> node2 <- node.getLower() + optional ReverseTreeOrder<#k,#v> current <- prev + while (present(node2)) { + current <- ReverseTreeOrder<#k,#v>{ require(node2), current } + node2 <- require(node2).getHigher() + } + return current + } + + get () { + return TreeKeyValue:create(node.getKey(),node.getValue()) + } } diff --git a/lib/container/src/Extension_Vector.cpp b/lib/container/src/Extension_Vector.cpp --- a/lib/container/src/Extension_Vector.cpp +++ b/lib/container/src/Extension_Vector.cpp @@ -24,7 +24,9 @@ #include "Category_Append.hpp" #include "Category_Container.hpp" #include "Category_Default.hpp" +#include "Category_DefaultOrder.hpp" #include "Category_Formatted.hpp" +#include "Category_Order.hpp" #include "Category_ReadAt.hpp" #include "Category_Stack.hpp" #include "Category_String.hpp" @@ -37,7 +39,7 @@ using VectorType = std::vector>; -S CreateValue_Vector(S parent, const ParamTuple& params, VectorType values); +S CreateValue_Vector(S parent, VectorType values); struct ExtCategory_Vector : public Category_Vector { ReturnTuple Call_copyFrom(const ParamTuple& params, const ValueTuple& args) final { @@ -49,13 +51,13 @@ for (int i = 0; i < size; ++i) { values.push_back(TypeValue::Call(Var_arg1, Function_ReadAt_readAt, ParamTuple(), ArgTuple(Box_Int(i))).Only()); } - return ReturnTuple(CreateValue_Vector(CreateType_Vector(Params<1>::Type(Param_y)), ParamTuple(), values)); + return ReturnTuple(CreateValue_Vector(CreateType_Vector(Params<1>::Type(Param_y)), values)); } ReturnTuple Call_create(const ParamTuple& params, const ValueTuple& args) final { TRACE_FUNCTION("Vector:create") const S Param_y = params.At(0); - return ReturnTuple(CreateValue_Vector(CreateType_Vector(Params<1>::Type(Param_y)), ParamTuple(), VectorType())); + return ReturnTuple(CreateValue_Vector(CreateType_Vector(Params<1>::Type(Param_y)), VectorType())); } ReturnTuple Call_createSize(const ParamTuple& params, const ValueTuple& args) final { @@ -66,7 +68,7 @@ for (int i = 0; i < Var_arg1; ++i) { values.push_back(TypeInstance::Call(Param_y, Function_Default_default, ParamTuple(), ArgTuple()).Only()); } - return ReturnTuple(CreateValue_Vector(CreateType_Vector(Params<1>::Type(Param_y)), ParamTuple(), values)); + return ReturnTuple(CreateValue_Vector(CreateType_Vector(Params<1>::Type(Param_y)), values)); } }; @@ -74,9 +76,31 @@ inline ExtType_Vector(Category_Vector& p, Params<1>::Type params) : Type_Vector(p, params) {} }; +struct VectorOrder : public AnonymousOrder { + VectorOrder(S container, const VectorType& v) + : AnonymousOrder(container, Function_Order_next, Function_Order_get), values(v) {} + + S Call_next(const S& self) final { + if (index+1 >= values.size()) { + return Var_empty; + } else { + ++index; + return self; + } + } + + S Call_get(const S& self) final { + if (index >= values.size()) FAIL() << "iterated past end of Vector"; + return values[index]; + } + + const VectorType& values; + int index = 0; +}; + struct ExtValue_Vector : public Value_Vector { - inline ExtValue_Vector(S p, const ParamTuple& params, VectorType v) - : Value_Vector(p, params), values(std::move(v)) {} + inline ExtValue_Vector(S p, VectorType v) + : Value_Vector(p), values(std::move(v)) {} ReturnTuple Call_append(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { TRACE_FUNCTION("Vector.append") @@ -86,6 +110,15 @@ return ReturnTuple(Var_self); } + ReturnTuple Call_defaultOrder(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Vector.defaultOrder") + if (values.empty()) { + return ReturnTuple(Var_empty); + } else { + return ReturnTuple(S_get(new VectorOrder(Var_self, values))); + } + } + ReturnTuple Call_pop(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { TRACE_FUNCTION("Vector.pop") std::lock_guard lock(mutex); @@ -147,8 +180,8 @@ }); return cache.GetOrCreate(params); } -S CreateValue_Vector(S parent, const ParamTuple& params, VectorType values) { - return S_get(new ExtValue_Vector(parent, params, values)); +S CreateValue_Vector(S parent, VectorType values) { + return S_get(new ExtValue_Vector(parent, values)); } #ifdef ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/container/vector.0rp b/lib/container/vector.0rp --- a/lib/container/vector.0rp +++ b/lib/container/vector.0rp @@ -21,10 +21,11 @@ // Params: // - #x: The value type contained. concrete Vector<#x> { + refines Append<#x> + refines DefaultOrder<#x> refines Stack<#x> refines ReadAt<#x> refines WriteAt<#x> - refines Append<#x> // Create a copy from another random-access container. @category copyFrom<#y> (ReadAt<#y>) -> (Vector<#y>) @@ -36,7 +37,7 @@ // // Notes: // - #y.default() should return a distinct value each time if #y is mutable. - // This means that modifying one element should not change others. + // This means that modifying one element should not change others. @category createSize<#y> #y defines Default (Int) -> (Vector<#y>) diff --git a/lib/container/vector.0rt b/lib/container/vector.0rt --- a/lib/container/vector.0rt +++ b/lib/container/vector.0rt @@ -113,6 +113,25 @@ } } +unittest traverseVector { + Int index <- 0 + Vector vector <- Vector:create() + \ vector.push(2) + \ vector.push(6) + \ vector.push(3) + \ vector.push(5) + \ vector.push(4) + \ vector.push(1) + + traverse (vector.defaultOrder() -> Int i) { + \ Testing.checkEquals(i,vector.readAt(index)) + index <- index+1 + } + + \ Testing.checkEquals(index,6) +} + + testcase "distinct default values in pre-sized Vector" { success } diff --git a/lib/file/src/Extension_RawFileReader.cpp b/lib/file/src/Extension_RawFileReader.cpp --- a/lib/file/src/Extension_RawFileReader.cpp +++ b/lib/file/src/Extension_RawFileReader.cpp @@ -25,7 +25,7 @@ namespace ZEOLITE_PUBLIC_NAMESPACE { #endif // ZEOLITE_PUBLIC_NAMESPACE -S CreateValue_RawFileReader(S parent, const ParamTuple& params, const ValueTuple& args); +S CreateValue_RawFileReader(S parent, const ValueTuple& args); struct ExtCategory_RawFileReader : public Category_RawFileReader { }; @@ -35,13 +35,13 @@ ReturnTuple Call_open(const S& Param_self, const ParamTuple& params, const ValueTuple& args) final { TRACE_FUNCTION("RawFileReader.open") - return ReturnTuple(CreateValue_RawFileReader(CreateType_RawFileReader(Params<0>::Type()), ParamTuple(), args)); + return ReturnTuple(CreateValue_RawFileReader(CreateType_RawFileReader(Params<0>::Type()), args)); } }; struct ExtValue_RawFileReader : public Value_RawFileReader { - inline ExtValue_RawFileReader(S p, const ParamTuple& params, const ValueTuple& args) - : Value_RawFileReader(p, params), + inline ExtValue_RawFileReader(S p, const ValueTuple& args) + : Value_RawFileReader(p), filename(args.At(0)->AsString()), file(new std::ifstream(filename, std::ios::in | std::ios::binary)) {} @@ -107,7 +107,7 @@ std::mutex mutex; const std::string filename; R file; - CAPTURE_CREATION + CAPTURE_CREATION("RawFileReader") }; Category_RawFileReader& CreateCategory_RawFileReader() { @@ -118,8 +118,8 @@ static const auto cached = S_get(new ExtType_RawFileReader(CreateCategory_RawFileReader(), Params<0>::Type())); return cached; } -S CreateValue_RawFileReader(S parent, const ParamTuple& params, const ValueTuple& args) { - return S_get(new ExtValue_RawFileReader(parent, params, args)); +S CreateValue_RawFileReader(S parent, const ValueTuple& args) { + return S_get(new ExtValue_RawFileReader(parent, args)); } #ifdef ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/file/src/Extension_RawFileWriter.cpp b/lib/file/src/Extension_RawFileWriter.cpp --- a/lib/file/src/Extension_RawFileWriter.cpp +++ b/lib/file/src/Extension_RawFileWriter.cpp @@ -25,7 +25,7 @@ namespace ZEOLITE_PUBLIC_NAMESPACE { #endif // ZEOLITE_PUBLIC_NAMESPACE -S CreateValue_RawFileWriter(S parent, const ParamTuple& params, const ValueTuple& args); +S CreateValue_RawFileWriter(S parent, const ValueTuple& args); struct ExtCategory_RawFileWriter : public Category_RawFileWriter { }; @@ -35,13 +35,13 @@ ReturnTuple Call_open(const S& Param_self, const ParamTuple& params, const ValueTuple& args) final { TRACE_FUNCTION("RawFileWriter.open") - return ReturnTuple(CreateValue_RawFileWriter(CreateType_RawFileWriter(Params<0>::Type()), ParamTuple(), args)); + return ReturnTuple(CreateValue_RawFileWriter(CreateType_RawFileWriter(Params<0>::Type()), args)); } }; struct ExtValue_RawFileWriter : public Value_RawFileWriter { - inline ExtValue_RawFileWriter(S p, const ParamTuple& params, const ValueTuple& args) - : Value_RawFileWriter(p, params), + inline ExtValue_RawFileWriter(S p, const ValueTuple& args) + : Value_RawFileWriter(p), filename(args.At(0)->AsString()), file(new std::ofstream(filename, std::ios::out | std::ios::binary | std::ios::trunc | std::ios::ate)) {} @@ -89,7 +89,7 @@ std::mutex mutex; const std::string filename; R file; - CAPTURE_CREATION + CAPTURE_CREATION("RawFileWriter") }; Category_RawFileWriter& CreateCategory_RawFileWriter() { @@ -100,8 +100,8 @@ static const auto cached = S_get(new ExtType_RawFileWriter(CreateCategory_RawFileWriter(), Params<0>::Type())); return cached; } -S CreateValue_RawFileWriter(S parent, const ParamTuple& params, const ValueTuple& args) { - return S_get(new ExtValue_RawFileWriter(parent, params, args)); +S CreateValue_RawFileWriter(S parent, const ValueTuple& args) { + return S_get(new ExtValue_RawFileWriter(parent, args)); } #ifdef ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/math/src/Extension_Math.cpp b/lib/math/src/Extension_Math.cpp --- a/lib/math/src/Extension_Math.cpp +++ b/lib/math/src/Extension_Math.cpp @@ -198,10 +198,6 @@ } }; -struct ExtValue_Math : public Value_Math { - inline ExtValue_Math(S p, const ParamTuple& params, const ValueTuple& args) : Value_Math(p, params) {} -}; - Category_Math& CreateCategory_Math() { static auto& category = *new ExtCategory_Math(); return category; diff --git a/lib/testing/helpers.0rp b/lib/testing/helpers.0rp --- a/lib/testing/helpers.0rp +++ b/lib/testing/helpers.0rp @@ -30,7 +30,7 @@ #x defines Equals<#x> (#x,#x) -> () - // Check that the value is within a range. Crashes if they are not equal. + // Check that the value is within a range. Crashes if it is not in the range. // // Args: // - #x: Actual value. diff --git a/lib/thread/.zeolite-module b/lib/thread/.zeolite-module --- a/lib/thread/.zeolite-module +++ b/lib/thread/.zeolite-module @@ -4,6 +4,7 @@ "lib/util" ] private_deps: [ + "lib/container" "lib/testing" ] extra_files: [ @@ -16,8 +17,21 @@ categories: [ProcessThread] } category_source { + source: "lib/thread/src/Extension_Realtime.cpp" + categories: [Realtime] + } + category_source { source: "lib/thread/src/Extension_SimpleMutex.cpp" categories: [SimpleMutex] + } + category_source { + source: "lib/thread/src/Extension_ThreadCondition.cpp" + categories: [ThreadCondition] + } + category_source { + source: "lib/thread/src/Extension_Enumerated.cpp" + categories: [EnumeratedBarrier EnumeratedWait] + requires: [Stack Vector] } ] mode: incremental { diff --git a/lib/thread/README.md b/lib/thread/README.md --- a/lib/thread/README.md +++ b/lib/thread/README.md @@ -10,12 +10,10 @@ ## Configuring and Building This library *is not* automatically built by `zeolite-setup`; you need to build -it manually. This is because there might be issues with linker dependencies -between different systems. +it manually. This is because there might be issues with thread-library +dependencies between different systems. -1. If you are running Linux, the config should work as-is. If you are running - FreeBSD, you might need to remove or change `"-lpthread"` at the bottom of - `.zeolite-module`. +1. If you are running Linux or FreeBSD, the config should work as-is. To build the library: diff --git a/lib/thread/barrier-ext.0rp b/lib/thread/barrier-ext.0rp new file mode 100644 --- /dev/null +++ b/lib/thread/barrier-ext.0rp @@ -0,0 +1,23 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 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$ + +concrete EnumeratedWait { + refines BarrierWait +} diff --git a/lib/thread/barrier.0rp b/lib/thread/barrier.0rp new file mode 100644 --- /dev/null +++ b/lib/thread/barrier.0rp @@ -0,0 +1,46 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 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] + +// Waits for a thread barrier. +@value interface BarrierWait { + // Block until the barrier condition is satisfied. + wait () -> (#self) +} + +// A thread barrier validated using thread enumeration. +concrete EnumeratedBarrier { + // Create a new barrier for a fixed number of threads. + // + // Args: + // - Int: Non-negative number of threads. + // + // Returns: + // - ReadAt: A list of the requested number of BarrierWait. These + // should be passed out to the respective threads. + // + // Notes: + // - Each thread must use its own BarrierWait; otherwise, there will be an + // error-checking crash. For example, passing readAt(0) to all threads is + // not allowed. + // - If a BarrierWait no longer has any references (and thus cannot be used), + // the barrier will be disabled. This will cause a crash if any thread is + // waiting for (or subsequently waits for) the barrier. This does not mean + // that you need to keep the ReadAt itself; one thread holding + // a reference to each individual BarrierWait is sufficient. + @type new (Int) -> (ReadAt) +} diff --git a/lib/thread/barrier.0rt b/lib/thread/barrier.0rt new file mode 100644 --- /dev/null +++ b/lib/thread/barrier.0rt @@ -0,0 +1,178 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 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 "EnumeratedBarrier tests" { + success +} + +unittest correctCount { + ReadAt barriers <- EnumeratedBarrier.new(13) + \ Testing.checkEquals(barriers.size(),13) +} + +unittest waitForOneThread { + ReadAt barriers <- EnumeratedBarrier.new(1) + \ barriers.readAt(0).wait() +} + +unittest zeroAllowed { + ReadAt barriers <- EnumeratedBarrier.new(0) + \ Testing.checkEquals(barriers.size(),0) +} + +unittest waitForMultipleThreads { + Value value <- Value.create() + Mutex mutex <- SimpleMutex.new() + ReadAt barriers <- EnumeratedBarrier.new(3) + + Thread thread1 <- ProcessThread.from(WaitAndIncrement.create(2,value,mutex,barriers.readAt(1))).start() + Thread thread2 <- ProcessThread.from(WaitAndIncrement.create(2,value,mutex,barriers.readAt(2))).start() + + \ barriers.readAt(0).wait() + \ Testing.checkEquals(value.get(),2) + + \ barriers.readAt(0).wait() + \ Testing.checkEquals(value.get(),4) + + \ thread1.join() + \ thread2.join() +} + +concrete WaitAndIncrement { + refines Routine + + @type create (Int,Value,Mutex,BarrierWait) -> (WaitAndIncrement) +} + +define WaitAndIncrement { + @value Int count + @value Value value + @value Mutex mutex + @value BarrierWait barrier + + create (count,value,mutex,barrier) { + return WaitAndIncrement{ count, value, mutex, barrier } + } + + run () { + scoped { + Int i <- 0 + } in while (i < count) { + $Hidden[i,count]$ + scoped { + MutexLock lock <- MutexLock.lock(mutex) + } cleanup { + \ lock.freeResource() + } in { + \ value.increment() + } + \ barrier.wait() + // Gives the main thread time to read the value. + \ Realtime.sleepSeconds(0.01) + } update { + i <- i+1 + } + } +} + + +testcase "EnumeratedBarrier crashes with negative count" { + crash + require "-4" +} + +unittest test { + ReadAt barriers <- EnumeratedBarrier.new(-4) +} + + +testcase "wait() crashes when references are lost" { + crash + require "BarrierWait.*destroyed" +} + +unittest test { + scoped { + ReadAt barriers <- EnumeratedBarrier.new(2) + } in BarrierWait barrier <- barriers.readAt(0) + \ barrier.wait() +} + + +testcase "references lost during wait() causes crash" { + crash + require "BarrierWait.*waiting" +} + +unittest test { + scoped { + ReadAt barriers <- EnumeratedBarrier.new(2) + } in { + Thread thread <- ProcessThread.from(WaitAndExit.create(barriers.readAt(0))).start() + // Give the thread time to start. + \ Realtime.sleepSeconds(0.1) + } +} + +concrete WaitAndExit { + refines Routine + + @type create (BarrierWait) -> (WaitAndExit) +} + +define WaitAndExit { + @value BarrierWait barrier + + create (barrier) { + return WaitAndExit{ barrier } + } + + run () { + \ barrier.wait() + } +} + + +testcase "wait() crashes when two threads use same BarrierWait" { + crash + require "BarrierWait.*in use" +} + +unittest test { + ReadAt barriers <- EnumeratedBarrier.new(2) + Thread thread <- ProcessThread.from(WaitAndExit.create(barriers.readAt(0))).start() + \ barriers.readAt(0).wait() +} + +concrete WaitAndExit { + refines Routine + + @type create (BarrierWait) -> (WaitAndExit) +} + +define WaitAndExit { + @value BarrierWait barrier + + create (barrier) { + return WaitAndExit{ barrier } + } + + run () { + \ barrier.wait() + } +} diff --git a/lib/thread/condition.0rp b/lib/thread/condition.0rp new file mode 100644 --- /dev/null +++ b/lib/thread/condition.0rp @@ -0,0 +1,106 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 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] + +// Blocks a thread until a condition is met. +// +// Notes: +// - Mutex logic is exposed so that it can be used to avoid race conditions with +// the thread signalling continuation. (For example, if blocking behavior is +// conditioned on the availability of input from another thread.) +@value interface ConditionWait { + refines Mutex + + // Block the current thread. + // + // Notes: + // - The current thread *must* lock() before wait() and unlock() after. The + // program could deadlock or crash otherwise. + // + // Example: + // + // scoped { + // MutexLock lock <- MutexLock.lock(threadWait) + // } cleanup { + // \ lock.freeResource() + // } in \ threadWait.wait() + // + // // continue processing here + wait () -> (#self) + + // Block the current thread for at most the specified amount of time. + // + // Args: + // - Float: Timeout in seconds. + // + // Returns: + // - Bool: Set to false iff the timeout was reached. + // + // Notes: + // - The current thread *must* lock() before timedWait() and unlock() after. + // The program could deadlock or crash otherwise. + // + // Example: + // + // scoped { + // MutexLock lock <- MutexLock.lock(threadWait) + // } cleanup { + // \ lock.freeResource() + // } in Bool success <- threadWait.timedWait(10.0) + // + // if (success) { + // // continue processing here + // } else { + // // error handling + // } + timedWait (Float) -> (Bool) +} + +// Resumes thread waiting for a condition. +// +// Example: +// +// ConditionWait cond <- // created elsewhere +// +// scoped { +// MutexLock lock <- MutexLock.lock(cond) +// } cleanup { +// \ lock.freeResource() +// } in { +// // prepare state for threads, e.g., read data from disk +// } +// +// // signal threads to continue +// \ cond.resumeAll() +@value interface ConditionResume { + refines Mutex + + // Resume all of the threads waiting for the associated condition. + resumeAll () -> (#self) + + // Resume one of the threads waiting for the associated condition. + resumeOne () -> (#self) +} + +// Provides a single resume mechanism for multiple waiting threads. +concrete ThreadCondition { + refines ConditionWait + refines ConditionResume + + // Create a new condition. + @type new () -> (ThreadCondition) +} diff --git a/lib/thread/condition.0rt b/lib/thread/condition.0rt new file mode 100644 --- /dev/null +++ b/lib/thread/condition.0rt @@ -0,0 +1,179 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 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 "ThreadCondition tests" { + success +} + +unittest resumeAll { + Value value <- Value.create() + ThreadCondition cond <- ThreadCondition.new() + + Thread thread1 <- ProcessThread.from(WaitAndUpdate.create(value,cond)).start() + Thread thread2 <- ProcessThread.from(WaitAndUpdate.create(value,cond)).start() + + // Wait for both threads to increment Value once, to indicate readiness. + while (true) { + scoped { + MutexLock lock <- MutexLock.lock(cond) + } cleanup { + \ lock.freeResource() + } in if (value.get() >= 2) { + break + } + } + + \ cond.resumeAll() + \ thread1.join() + \ thread2.join() + + \ Testing.checkEquals(value.get(),4) +} + +unittest resumeOne { + Value value <- Value.create() + ThreadCondition cond <- ThreadCondition.new() + + Thread thread1 <- ProcessThread.from(WaitAndUpdate.create(value,cond)).start() + Thread thread2 <- ProcessThread.from(WaitAndUpdate.create(value,cond)).start() + + \ Realtime.sleepSeconds(0.01) + + // Wait for both threads to increment Value once, to indicate readiness. + while (true) { + scoped { + MutexLock lock <- MutexLock.lock(cond) + } cleanup { + \ lock.freeResource() + } in if (value.get() >= 2) { + break + } + } + + \ cond.resumeOne() + \ thread1.join() + \ thread2.join() + + \ Testing.checkEquals(value.get(),3) +} + +unittest forceWaitTimeout { + Value value <- Value.create() + ThreadCondition cond <- ThreadCondition.new() + + Thread thread <- ProcessThread.from(WaitAndUpdate.create(value,cond)).start() + + \ Realtime.sleepSeconds(0.2) + \ cond.resumeOne() + \ thread.join() + + \ Testing.checkEquals(value.get(),1) +} + +unittest waitNoTimeout { + ThreadCondition cond <- ThreadCondition.new() + + Thread thread <- ProcessThread.from(JustWait.create(cond)).start() + + \ Realtime.sleepSeconds(0.1) + \ cond.resumeOne() + \ thread.join() + \ cond.lock().unlock() +} + +concrete JustWait { + refines Routine + + @type create (ConditionWait) -> (JustWait) +} + +define JustWait { + @value ConditionWait cond + + create (cond) { + return JustWait{ cond } + } + + run () { + scoped { + MutexLock lock <- MutexLock.lock(cond) + } cleanup { + \ lock.freeResource() + } in \ cond.wait() + } +} + +concrete WaitAndUpdate { + refines Routine + + @type create (Value,ConditionWait) -> (WaitAndUpdate) +} + +define WaitAndUpdate { + @value Value value + @value ConditionWait cond + + create (value,cond) { + return WaitAndUpdate{ value, cond } + } + + run () { + scoped { + MutexLock lock <- MutexLock.lock(cond) + // Increment once, to indicate readiness. + \ value.increment() + } cleanup { + \ lock.freeResource() + } in { + // Mutex isn't unlocked until blocked here. + if (cond.timedWait(0.1)) { + \ value.increment() + } + } + } +} + + +testcase "wait() crashes if not locked first" { + crash + require "waiting for condition" +} + +unittest test { + \ ThreadCondition.new().wait() +} + + +testcase "timedWait() crashes if not locked first" { + crash + require "waiting for condition" +} + +unittest test { + \ ThreadCondition.new().timedWait(0.1) +} + + +testcase "timedWait() crashes with negative wait" { + crash + require "-0\.1" +} + +unittest test { + \ ThreadCondition.new().lock().timedWait(-0.1) +} diff --git a/lib/thread/mutex.0rt b/lib/thread/mutex.0rt --- a/lib/thread/mutex.0rt +++ b/lib/thread/mutex.0rt @@ -101,38 +101,3 @@ } } } - -concrete Value { - @type create () -> (Value) - - @value get () -> (Int) - @value increment () -> () - - @value setInUse (Bool) -> () - @value getInUse () -> (Bool) -} - -define Value { - @value Int value - @value Bool inUse - - create () { - return Value{ 0, false } - } - - get () { - return value - } - - increment () { - value <- value+1 - } - - setInUse (i) { - inUse <- i - } - - getInUse () { - return inUse - } -} diff --git a/lib/thread/src/Extension_Enumerated.cpp b/lib/thread/src/Extension_Enumerated.cpp new file mode 100644 --- /dev/null +++ b/lib/thread/src/Extension_Enumerated.cpp @@ -0,0 +1,194 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 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 +#include + +#include "category-source.hpp" +#include "Streamlined_EnumeratedWait.hpp" +#include "Streamlined_EnumeratedBarrier.hpp" +#include "Category_BarrierWait.hpp" +#include "Category_EnumeratedBarrier.hpp" +#include "Category_Int.hpp" +#include "Category_Stack.hpp" +#include "Category_Vector.hpp" + +namespace { + +class Barrier { + public: + Barrier(int count) : index_usage(new std::atomic_int[count]) { + alive.store(true); + wait_count.store(0); + for (int i = 0; i < count; ++i) { + index_usage[i].store(0); + } + int error = pthread_barrier_init(&barrier, NULL, count); + if (error != 0) { + FAIL() << "Error creating barrier: " << strerror(error) << " (error " << error << ")"; + } + } + + void Wait(int index) { + TRACE_CREATION + Enter(index); + int error = pthread_barrier_wait(&barrier); + if (error != 0 && error != PTHREAD_BARRIER_SERIAL_THREAD) { + FAIL() << "Error waiting for barrier: " << strerror(error) << " (error " << error << ")"; + } + Exit(index); + } + + void Kill(int index) { + TRACE_CREATION + if (alive.exchange(false) && wait_count.load() > 0) { + FAIL() << "BarrierWait at index " << index << " destroyed while one or more threads were waiting"; + } + } + + ~Barrier() { + TRACE_CREATION + int error = pthread_barrier_destroy(&barrier); + if (error != 0) { + FAIL() << "Error cleaning up barrier: " << strerror(error) << " (error " << error << ")"; + } + } + +private: + void Enter(int index) { + ++wait_count; + if (!alive.load()) { + --wait_count; + FAIL() << "One or more BarrierWait have been destroyed"; + } + if (++index_usage[index] > 1) { + Exit(index); + FAIL() << "BarrierWait at index " << index << " is already in use"; + } + } + + void Exit(int index) { + --wait_count; + --index_usage[index]; + } + + std::atomic_bool alive; + std::atomic_int wait_count; + const R index_usage; + pthread_barrier_t barrier; + CAPTURE_CREATION("EnumeratedBarrier") +}; + +} // namespace + +#ifdef ZEOLITE_PRIVATE_NAMESPACE +namespace ZEOLITE_PRIVATE_NAMESPACE { +#endif // ZEOLITE_PRIVATE_NAMESPACE + +S CreateValue_EnumeratedWait( + S parent, S b, int i); + +struct ExtCategory_EnumeratedWait : public Category_EnumeratedWait { +}; + +struct ExtType_EnumeratedWait : public Type_EnumeratedWait { + inline ExtType_EnumeratedWait(Category_EnumeratedWait& p, Params<0>::Type params) : Type_EnumeratedWait(p, params) {} +}; + +struct ExtValue_EnumeratedWait : public Value_EnumeratedWait { + inline ExtValue_EnumeratedWait(S p, S b, int i) + : Value_EnumeratedWait(p), barrier(b), index(i) {} + + ReturnTuple Call_wait(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("EnumeratedWait.wait") + barrier->Wait(index); + return ReturnTuple(Var_self); + } + + ~ExtValue_EnumeratedWait() { + barrier->Kill(index); + } + + const S barrier; + int index; +}; + +Category_EnumeratedWait& CreateCategory_EnumeratedWait() { + static auto& category = *new ExtCategory_EnumeratedWait(); + return category; +} +S CreateType_EnumeratedWait(Params<0>::Type params) { + static const auto cached = S_get(new ExtType_EnumeratedWait(CreateCategory_EnumeratedWait(), Params<0>::Type())); + return cached; +} +S CreateValue_EnumeratedWait( + S parent, S b, int i) { + return S_get(new ExtValue_EnumeratedWait(parent, b, i)); +} + +#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 + +struct ExtCategory_EnumeratedBarrier : public Category_EnumeratedBarrier { +}; + +struct ExtType_EnumeratedBarrier : public Type_EnumeratedBarrier { + inline ExtType_EnumeratedBarrier(Category_EnumeratedBarrier& p, Params<0>::Type params) : Type_EnumeratedBarrier(p, params) {} + + ReturnTuple Call_new(const S& Param_self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("EnumeratedBarrier.new") + const PrimInt Var_arg1 = (args.At(0))->AsInt(); + if (Var_arg1 < 0) { + FAIL() << "Invalid barrier thread count " << Var_arg1; + } + S vector = GetCategory_Vector().Call( + Function_Vector_create, + ParamTuple(GetType_EnumeratedWait(Params<0>::Type())), + ArgTuple()).Only(); + S barrier(Var_arg1? new Barrier(Var_arg1) : nullptr); + for (int i = 0; i < Var_arg1; ++i) { + S wait = CreateValue_EnumeratedWait( + CreateType_EnumeratedWait(Params<0>::Type()), barrier, i); + TypeValue::Call(vector, Function_Stack_push, ParamTuple(), ArgTuple(wait)); + } + return ReturnTuple(vector); + } +}; + +Category_EnumeratedBarrier& CreateCategory_EnumeratedBarrier() { + static auto& category = *new ExtCategory_EnumeratedBarrier(); + return category; +} +S CreateType_EnumeratedBarrier(Params<0>::Type params) { + static const auto cached = S_get(new ExtType_EnumeratedBarrier(CreateCategory_EnumeratedBarrier(), Params<0>::Type())); + return cached; +} + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/thread/src/Extension_MutexLock.cpp b/lib/thread/src/Extension_MutexLock.cpp --- a/lib/thread/src/Extension_MutexLock.cpp +++ b/lib/thread/src/Extension_MutexLock.cpp @@ -28,7 +28,7 @@ namespace ZEOLITE_PUBLIC_NAMESPACE { #endif // ZEOLITE_PUBLIC_NAMESPACE -S CreateValue_MutexLock(S parent, const ParamTuple& params, const ValueTuple& args); +S CreateValue_MutexLock(S parent, const ValueTuple& args); struct ExtCategory_MutexLock : public Category_MutexLock { }; @@ -38,18 +38,18 @@ ReturnTuple Call_lock(const S& Param_self, const ParamTuple& params, const ValueTuple& args) final { TRACE_FUNCTION("MutexLock.lock") - return ReturnTuple(CreateValue_MutexLock(CreateType_MutexLock(Params<0>::Type()), ParamTuple(), args)); + return ReturnTuple(CreateValue_MutexLock(CreateType_MutexLock(Params<0>::Type()), args)); } }; struct ExtValue_MutexLock : public Value_MutexLock { - inline ExtValue_MutexLock(S p, const ParamTuple& params, const ValueTuple& args) - : Value_MutexLock(p, params), mutex(args.Only()) { + inline ExtValue_MutexLock(S p, const ValueTuple& args) + : Value_MutexLock(p), mutex(args.Only()) { TypeValue::Call(mutex, Function_Mutex_lock, ParamTuple(), ArgTuple()); } ReturnTuple Call_freeResource(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("PersistentResource.freeResource") + TRACE_FUNCTION("MutexLock.freeResource") TRACE_CREATION if (!mutex) { FAIL() << "MutexLock freed multiple times"; @@ -70,7 +70,7 @@ } S mutex; - CAPTURE_CREATION + CAPTURE_CREATION("MutexLock") }; Category_MutexLock& CreateCategory_MutexLock() { @@ -81,8 +81,8 @@ static const auto cached = S_get(new ExtType_MutexLock(CreateCategory_MutexLock(), Params<0>::Type())); return cached; } -S CreateValue_MutexLock(S parent, const ParamTuple& params, const ValueTuple& args) { - return S_get(new ExtValue_MutexLock(parent, params, args)); +S CreateValue_MutexLock(S parent, const ValueTuple& args) { + return S_get(new ExtValue_MutexLock(parent, args)); } #ifdef ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/thread/src/Extension_ProcessThread.cpp b/lib/thread/src/Extension_ProcessThread.cpp --- a/lib/thread/src/Extension_ProcessThread.cpp +++ b/lib/thread/src/Extension_ProcessThread.cpp @@ -31,7 +31,7 @@ namespace ZEOLITE_PUBLIC_NAMESPACE { #endif // ZEOLITE_PUBLIC_NAMESPACE -S CreateValue_ProcessThread(S parent, const ParamTuple& params, const ValueTuple& args); +S CreateValue_ProcessThread(S parent, const ValueTuple& args); struct ExtCategory_ProcessThread : public Category_ProcessThread { }; @@ -41,16 +41,16 @@ ReturnTuple Call_from(const S& Param_self, const ParamTuple& params, const ValueTuple& args) final { TRACE_FUNCTION("ProcessThread.from") - return ReturnTuple(CreateValue_ProcessThread(CreateType_ProcessThread(Params<0>::Type()), params, args)); + return ReturnTuple(CreateValue_ProcessThread(CreateType_ProcessThread(Params<0>::Type()), args)); } }; struct ExtValue_ProcessThread : public Value_ProcessThread { - inline ExtValue_ProcessThread(S p, const ParamTuple& params, const ValueTuple& args) - : Value_ProcessThread(p, params), routine(args.Only()) {} + inline ExtValue_ProcessThread(S p, const ValueTuple& args) + : Value_ProcessThread(p), routine(args.Only()) {} ReturnTuple Call_detach(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Thread.detach") + TRACE_FUNCTION("ProcessThread.detach") S temp = thread; thread = nullptr; if (!isJoinable(temp.get())) { @@ -62,12 +62,12 @@ } ReturnTuple Call_isRunning(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Thread.isRunning") + TRACE_FUNCTION("ProcessThread.isRunning") return ReturnTuple(Box_Bool(isJoinable(thread.get()))); } ReturnTuple Call_join(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Thread.join") + TRACE_FUNCTION("ProcessThread.join") S temp = thread; thread = nullptr; if (!isJoinable(temp.get())) { @@ -79,7 +79,7 @@ } ReturnTuple Call_start(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Process.start") + TRACE_FUNCTION("ProcessThread.start") if (isJoinable(thread.get())) { FAIL() << "thread is already running"; } else { @@ -87,10 +87,10 @@ // it's still running. This allows the caller to hold a weak reference to // the thread. thread.reset(new std::thread( - [this,Var_self] { + capture_thread::ThreadCrosser::WrapCall([this,Var_self] { TRACE_CREATION TypeValue::Call(routine, Function_Routine_run, ParamTuple(), ArgTuple()); - })); + }))); } return ReturnTuple(Var_self); } @@ -109,7 +109,7 @@ const S routine; S thread; - CAPTURE_CREATION + CAPTURE_CREATION("ProcessThread") }; Category_ProcessThread& CreateCategory_ProcessThread() { @@ -120,8 +120,8 @@ static const auto cached = S_get(new ExtType_ProcessThread(CreateCategory_ProcessThread(), Params<0>::Type())); return cached; } -S CreateValue_ProcessThread(S parent, const ParamTuple& params, const ValueTuple& args) { - return S_get(new ExtValue_ProcessThread(parent, params, args)); +S CreateValue_ProcessThread(S parent, const ValueTuple& args) { + return S_get(new ExtValue_ProcessThread(parent, args)); } #ifdef ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/thread/src/Extension_Realtime.cpp b/lib/thread/src/Extension_Realtime.cpp new file mode 100644 --- /dev/null +++ b/lib/thread/src/Extension_Realtime.cpp @@ -0,0 +1,69 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 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 +#include +#include + +#include "category-source.hpp" +#include "Streamlined_Realtime.hpp" +#include "Category_Float.hpp" +#include "Category_Realtime.hpp" + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE + +struct ExtCategory_Realtime : public Category_Realtime { +}; + +struct ExtType_Realtime : public Type_Realtime { + inline ExtType_Realtime(Category_Realtime& p, Params<0>::Type params) : Type_Realtime(p, params) {} + ReturnTuple Call_sleepSeconds(const S& Param_self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Realtime.sleepSeconds") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + if (Var_arg1 < 0) { + FAIL() << "Bad wait time " << Var_arg1; + } + struct timespec timeout{ (int) trunc(Var_arg1), (int) (1000000000.0 * (Var_arg1-trunc(Var_arg1))) }; + struct timespec remainder; + while (nanosleep(&timeout, &remainder) != 0) { + if (errno == EINTR) { + timeout = remainder; + } else { + FAIL() << "Error sleeping: " << strerror(errno) << " (error " << errno << ")"; + } + } + return ReturnTuple(); + } +}; + +Category_Realtime& CreateCategory_Realtime() { + static auto& category = *new ExtCategory_Realtime(); + return category; +} +S CreateType_Realtime(Params<0>::Type params) { + static const auto cached = S_get(new ExtType_Realtime(CreateCategory_Realtime(), Params<0>::Type())); + return cached; +} + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/thread/src/Extension_SimpleMutex.cpp b/lib/thread/src/Extension_SimpleMutex.cpp --- a/lib/thread/src/Extension_SimpleMutex.cpp +++ b/lib/thread/src/Extension_SimpleMutex.cpp @@ -42,16 +42,16 @@ }; struct ExtValue_SimpleMutex : public Value_SimpleMutex { - inline ExtValue_SimpleMutex(S p, const ParamTuple& params) : Value_SimpleMutex(p, params) {} + inline ExtValue_SimpleMutex(S p) : Value_SimpleMutex(p) {} ReturnTuple Call_lock(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Mutex.lock") + TRACE_FUNCTION("SimpleMutex.lock") mutex.lock(); return ReturnTuple(Var_self); } ReturnTuple Call_unlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Mutex.unlock") + TRACE_FUNCTION("SimpleMutex.unlock") mutex.unlock(); return ReturnTuple(Var_self); } @@ -68,7 +68,7 @@ return cached; } S CreateValue_SimpleMutex(S parent) { - return S_get(new ExtValue_SimpleMutex(parent, ParamTuple())); + return S_get(new ExtValue_SimpleMutex(parent)); } #ifdef ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/thread/src/Extension_ThreadCondition.cpp b/lib/thread/src/Extension_ThreadCondition.cpp new file mode 100644 --- /dev/null +++ b/lib/thread/src/Extension_ThreadCondition.cpp @@ -0,0 +1,164 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 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 +#include +#include +#include + +#include "category-source.hpp" +#include "Streamlined_ThreadCondition.hpp" +#include "Category_ThreadCondition.hpp" +#include "Category_ConditionResume.hpp" +#include "Category_ConditionWait.hpp" + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE + +S CreateValue_ThreadCondition(S parent); + +struct ExtCategory_ThreadCondition : public Category_ThreadCondition { +}; + +struct ExtType_ThreadCondition : public Type_ThreadCondition { + inline ExtType_ThreadCondition(Category_ThreadCondition& p, Params<0>::Type params) : Type_ThreadCondition(p, params) {} + + ReturnTuple Call_new(const S& Param_self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("ThreadCondition.new") + return ReturnTuple(CreateValue_ThreadCondition(CreateType_ThreadCondition(Params<0>::Type()))); + } +}; + +struct ExtValue_ThreadCondition : public Value_ThreadCondition { + inline ExtValue_ThreadCondition(S p) : Value_ThreadCondition(p) { + pthread_mutexattr_t mutex_attr; + pthread_mutexattr_init(&mutex_attr); + // NOTE: Error checking is required to catch attempted waits without first + // locking the mutex. + pthread_mutexattr_settype(&mutex_attr, PTHREAD_MUTEX_ERRORCHECK); + pthread_mutex_init(&mutex, &mutex_attr); + } + + ReturnTuple Call_lock(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("ThreadCondition.lock") + int error = 0; + if ((error = pthread_mutex_lock(&mutex)) != 0) { + FailError("Error locking mutex", error); + } + return ReturnTuple(Var_self); + } + + ReturnTuple Call_resumeAll(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("ThreadCondition.resumeAll") + int error = 0; + if ((error = pthread_cond_broadcast(&cond)) != 0) { + FailError("Error resuming threads", error); + } + return ReturnTuple(Var_self); + } + + ReturnTuple Call_resumeOne(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("ThreadCondition.resumeOne") + int error = 0; + if ((error = pthread_cond_signal(&cond)) != 0) { + FailError("Error resuming thread", error); + } + return ReturnTuple(Var_self); + } + + ReturnTuple Call_timedWait(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("ThreadCondition.timedWait") + int error = 0; + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + if (Var_arg1 < 0) { + FAIL() << "Bad wait time " << Var_arg1; + } + struct timeval now; + if (gettimeofday(&now, NULL) != 0) { + FailError("Error getting current time", errno); + } + const PrimFloat abs_time = Var_arg1 + (PrimFloat) now.tv_sec + ((PrimFloat) now.tv_usec / 1000000.0); + struct timespec timeout{ (int) trunc(abs_time), (int) (1000000000.0 * (abs_time-trunc(abs_time))) }; + error = pthread_cond_timedwait(&cond, &mutex, &timeout); + if (error == ETIMEDOUT) { + return ReturnTuple(Box_Bool(false)); + } + if (error != 0) { + FailError("Error waiting for condition", error); + } + return ReturnTuple(Box_Bool(true)); + } + + ReturnTuple Call_unlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("ThreadCondition.unlock") + int error = 0; + if ((error = pthread_mutex_unlock(&mutex)) != 0) { + FailError("Error unlocking mutex", error); + } + return ReturnTuple(Var_self); + } + + ReturnTuple Call_wait(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("ThreadCondition.wait") + int error = 0; + if ((error = pthread_cond_wait(&cond, &mutex)) != 0) { + FailError("Error waiting for condition", error); + } + return ReturnTuple(Var_self); + } + + void FailError(const std::string& context, int error) const { + TRACE_CREATION + FAIL() << context << ": " << strerror(error) << " (error " << error << ")"; + } + + ~ExtValue_ThreadCondition() { + int error = 0; + // Nothing should be waiting on the condition, because then there would + // still be a reference to this object. + if ((error = pthread_cond_destroy(&cond)) != 0) { + FailError("Error cleaning up condition", error); + } + if ((error = pthread_mutex_destroy(&mutex)) != 0) { + FailError("Error cleaning up mutex", error); + } + } + + pthread_cond_t cond = PTHREAD_COND_INITIALIZER; + pthread_mutex_t mutex; + CAPTURE_CREATION("ThreadCondition") +}; + +Category_ThreadCondition& CreateCategory_ThreadCondition() { + static auto& category = *new ExtCategory_ThreadCondition(); + return category; +} +S CreateType_ThreadCondition(Params<0>::Type params) { + static const auto cached = S_get(new ExtType_ThreadCondition(CreateCategory_ThreadCondition(), Params<0>::Type())); + return cached; +} +S CreateValue_ThreadCondition(S parent) { + return S_get(new ExtValue_ThreadCondition(parent)); +} + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/thread/testing.0rp b/lib/thread/testing.0rp --- a/lib/thread/testing.0rp +++ b/lib/thread/testing.0rp @@ -24,3 +24,19 @@ @type create () -> (NoOpRoutine) } + +concrete InfiniteRoutine { + refines Routine + + @type create () -> (InfiniteRoutine) +} + +concrete Value { + @type create () -> (Value) + + @value get () -> (Int) + @value increment () -> () + + @value setInUse (Bool) -> () + @value getInUse () -> (Bool) +} diff --git a/lib/thread/testing.0rx b/lib/thread/testing.0rx --- a/lib/thread/testing.0rx +++ b/lib/thread/testing.0rx @@ -25,3 +25,38 @@ run () {} } + +define InfiniteRoutine { + create () { + return InfiniteRoutine{ } + } + + run () { + while (true) {} + } +} + +define Value { + @value Int value + @value Bool inUse + + create () { + return Value{ 0, false } + } + + get () { + return value + } + + increment () { + value <- value+1 + } + + setInUse (i) { + inUse <- i + } + + getInUse () { + return inUse + } +} diff --git a/lib/thread/thread.0rt b/lib/thread/thread.0rt --- a/lib/thread/thread.0rt +++ b/lib/thread/thread.0rt @@ -21,7 +21,7 @@ } unittest test { - Counter counter <- Counter.create(10000) + CountLoop counter <- CountLoop.create(10000) \ Testing.checkEquals(counter.get(),0) \ counter.start() \ Testing.checkEquals(counter.get(),10000) @@ -29,14 +29,14 @@ \ Testing.checkEquals(counter.get(),20000) } -concrete Counter { +concrete CountLoop { refines Process - @type create (Int) -> (Counter) + @type create (Int) -> (CountLoop) @value get () -> (Int) } -define Counter { +define CountLoop { refines Routine @value Int current @@ -44,7 +44,7 @@ @value weak Thread thread create (c) { - return Counter{ 0, c, empty } + return CountLoop{ 0, c, empty } } start () { @@ -78,6 +78,32 @@ } +testcase "Argv available in Thread" { + success + args "arg1" +} + +unittest test { + \ ProcessThread.from(CheckArgv.create()).start().join() +} + +concrete CheckArgv { + refines Routine + + @type create () -> (CheckArgv) +} + +define CheckArgv { + create () { + return CheckArgv{ } + } + + run () { + \ Testing.checkEquals(Argv.global().readAt(1),"arg1") + } +} + + testcase "join() crashes if Thread not started yet" { crash require "thread.*started" @@ -88,13 +114,22 @@ } +testcase "join() once" { + success +} + +unittest test { + \ ProcessThread.from(NoOpRoutine.create()).start().join() +} + + testcase "join() twice crashes" { crash require "thread.*started" } unittest test { - \ ProcessThread.from(NoOpRoutine.create()).join().join() + \ ProcessThread.from(NoOpRoutine.create()).start().join().join() } @@ -104,17 +139,26 @@ } unittest test { - \ ProcessThread.from(NoOpRoutine.create()).detach() + \ ProcessThread.from(InfiniteRoutine.create()).detach() } +testcase "detach() once" { + success +} + +unittest test { + \ ProcessThread.from(InfiniteRoutine.create()).start().detach() +} + + testcase "detach() twice crashes" { crash require "thread.*started" } unittest test { - \ ProcessThread.from(NoOpRoutine.create()).detach().detach() + \ ProcessThread.from(InfiniteRoutine.create()).start().detach().detach() } diff --git a/lib/thread/time.0rp b/lib/thread/time.0rp new file mode 100644 --- /dev/null +++ b/lib/thread/time.0rp @@ -0,0 +1,23 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 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] + +// Functions for realtime computation. +concrete Realtime { + // Sleep for the given number of seconds. + @type sleepSeconds (Float) -> () +} diff --git a/lib/thread/time.0rt b/lib/thread/time.0rt new file mode 100644 --- /dev/null +++ b/lib/thread/time.0rt @@ -0,0 +1,35 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 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 "negative sleepSeconds() crashes" { + crash + require "-0\.1" +} + +unittest test { + \ Realtime.sleepSeconds(-0.1) +} + + +testcase "zero sleepSeconds() is allowed" { + success +} + +unittest test { + \ Realtime.sleepSeconds(0.0) +} diff --git a/lib/util/counters.0rp b/lib/util/counters.0rp new file mode 100644 --- /dev/null +++ b/lib/util/counters.0rp @@ -0,0 +1,33 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 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] + +// Creates Order counters, for use with traverse. +concrete Counter { + // Create a sequence of indices for a Container of the given size. + @type zeroIndexed (Int) -> (optional Order) + // Create an unbounded Int sequence. + @type unlimited () -> (optional Order) +} + +// Creates an Order<#x> that repeats a single value, for use with traverse. +concrete Repeat<#x> { + // Repeat the value the specified number of times. + @category times<#y> (#y,Int) -> (optional Order<#y>) + // Repeat the value an unlimited number of times. + @category unlimited<#y> (#y) -> (optional Order<#y>) +} diff --git a/lib/util/counters.0rt b/lib/util/counters.0rt new file mode 100644 --- /dev/null +++ b/lib/util/counters.0rt @@ -0,0 +1,69 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 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 "counter tests" { + success +} + +unittest zeroIndexed { + Int index <- 0 + + traverse (Counter.zeroIndexed(10) -> Int i) { + \ Testing.checkEquals(i,index) + index <- index+1 + } + + \ Testing.checkEquals(index,10) +} + +unittest unlimitedCount { + Int index <- 0 + + traverse (Counter.unlimited() -> Int i) { + \ Testing.checkEquals(i,index) + if ((index <- index+1) >= 10) { + break + } + } + + \ Testing.checkEquals(index,10) +} + +unittest times { + Int index <- 0 + + traverse ("message" `Repeat:times` 10 -> String m) { + \ Testing.checkEquals(m,"message") + index <- index+1 + } + + \ Testing.checkEquals(index,10) +} + +unittest unlimitedValue { + Int index <- 0 + + traverse (Repeat:unlimited("message") -> String m) { + \ Testing.checkEquals(m,"message") + if ((index <- index+1) >= 10) { + break + } + } + + \ Testing.checkEquals(index,10) +} diff --git a/lib/util/counters.0rx b/lib/util/counters.0rx new file mode 100644 --- /dev/null +++ b/lib/util/counters.0rx @@ -0,0 +1,86 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 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 Counter { + $ReadOnly[max]$ + + refines Order + + @value Int current + @value Int max + + zeroIndexed (max) { + if (max <= 0) { + return empty + } else { + return Counter{ 0, max } + } + } + + unlimited () { + return Counter{ 0, -1 } + } + + next () { + if (max < 0 || current+1 < max) { + current <- current+1 + return self + } else { + return empty + } + } + + get () { + return current + } +} + +define Repeat { + $ReadOnly[max,value]$ + + refines Order<#x> + + @value #x value + @value Int current + @value Int max + + times (value,max) { + if (max <= 0) { + return empty + } else { + return Repeat<#y>{ value, 0, max } + } + } + + unlimited (value) { + return Repeat<#y>{ value, 0, -1 } + } + + next () { + if (max < 0 || current+1 < max) { + current <- current+1 + return self + } else { + return empty + } + } + + get () { + return value + } +} diff --git a/lib/util/extra.0rp b/lib/util/extra.0rp --- a/lib/util/extra.0rp +++ b/lib/util/extra.0rp @@ -60,7 +60,6 @@ // Return the global set of arguments for the program. // // Notes: - // - This is empty outside of the main program thread. // - When used in unit tests, arg 0 is "testcase" and the remaining args are // set from args in the testcase. (See extra.0rt.) @type global () -> ([ReadAt&SubSequence]) diff --git a/lib/util/src/Extension_Argv.cpp b/lib/util/src/Extension_Argv.cpp --- a/lib/util/src/Extension_Argv.cpp +++ b/lib/util/src/Extension_Argv.cpp @@ -22,7 +22,7 @@ namespace ZEOLITE_PUBLIC_NAMESPACE { #endif // ZEOLITE_PUBLIC_NAMESPACE -S CreateValue_Argv(S parent, const ParamTuple& params, int st, int sz); +S CreateValue_Argv(S parent, int st, int sz); namespace { extern const S& Var_global; @@ -41,8 +41,8 @@ }; struct ExtValue_Argv : public Value_Argv { - inline ExtValue_Argv(S p, const ParamTuple& params, int st, int sz) - : Value_Argv(p, params), start(st), size(sz) {} + inline ExtValue_Argv(S p, int st, int sz) + : Value_Argv(p), start(st), size(sz) {} ReturnTuple Call_readAt(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { TRACE_FUNCTION("Argv.readAt") @@ -65,7 +65,7 @@ if (Var_arg2 < 0 || Var_arg1 + Var_arg2 > GetSize()) { FAIL() << "size " << Var_arg2 << " is invalid"; } - return ReturnTuple(S(new ExtValue_Argv(parent, ParamTuple(), start + Var_arg1, Var_arg2))); + return ReturnTuple(S(new ExtValue_Argv(parent, start + Var_arg1, Var_arg2))); } inline int GetSize() const { return size < 0 ? Argv::ArgCount() : size; } @@ -75,7 +75,7 @@ }; namespace { -const S& Var_global = *new S(new ExtValue_Argv(CreateType_Argv(Params<0>::Type()), ParamTuple(), 0, -1)); +const S& Var_global = *new S(new ExtValue_Argv(CreateType_Argv(Params<0>::Type()), 0, -1)); } // namespace Category_Argv& CreateCategory_Argv() { @@ -86,8 +86,8 @@ static const auto cached = S_get(new ExtType_Argv(CreateCategory_Argv(), Params<0>::Type())); return cached; } -S CreateValue_Argv(S parent, const ParamTuple& params, int st, int sz) { - return S_get(new ExtValue_Argv(parent, params, st, sz)); +S CreateValue_Argv(S parent, int st, int sz) { + return S_get(new ExtValue_Argv(parent, st, sz)); } #ifdef ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/util/src/Extension_SimpleInput.cpp b/lib/util/src/Extension_SimpleInput.cpp --- a/lib/util/src/Extension_SimpleInput.cpp +++ b/lib/util/src/Extension_SimpleInput.cpp @@ -42,7 +42,7 @@ }; struct ExtValue_SimpleInput : public Value_SimpleInput { - inline ExtValue_SimpleInput(S p, const ParamTuple& params, const ValueTuple& args) : Value_SimpleInput(p, params) {} + inline ExtValue_SimpleInput(S p, const ValueTuple& args) : Value_SimpleInput(p) {} ReturnTuple Call_pastEnd(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { TRACE_FUNCTION("SimpleInput.pastEnd") @@ -72,7 +72,7 @@ }; namespace { -const S& Var_stdin = *new S(new ExtValue_SimpleInput(CreateType_SimpleInput(Params<0>::Type()), ParamTuple(), ArgTuple())); +const S& Var_stdin = *new S(new ExtValue_SimpleInput(CreateType_SimpleInput(Params<0>::Type()), ArgTuple())); } // namespace Category_SimpleInput& CreateCategory_SimpleInput() { diff --git a/lib/util/src/Extension_SimpleOutput.cpp b/lib/util/src/Extension_SimpleOutput.cpp --- a/lib/util/src/Extension_SimpleOutput.cpp +++ b/lib/util/src/Extension_SimpleOutput.cpp @@ -63,8 +63,8 @@ } // namespace struct ExtValue_SimpleOutput : public Value_SimpleOutput { - inline ExtValue_SimpleOutput(S p, const ParamTuple& params, S w) - : Value_SimpleOutput(p, params), writer(w) {} + inline ExtValue_SimpleOutput(S p, S w) + : Value_SimpleOutput(p), writer(w) {} ReturnTuple Call_flush(const S& Var_self, const ParamTuple& params, const ValueTuple& args) final { TRACE_FUNCTION("SimpleOutput.flush") @@ -115,9 +115,9 @@ std::ostringstream output; }; -const S& Var_stdout = *new S(new ExtValue_SimpleOutput(CreateType_SimpleOutput(Params<0>::Type()), ParamTuple(), S_get(new StreamWriter(std::cout)))); -const S& Var_stderr = *new S(new ExtValue_SimpleOutput(CreateType_SimpleOutput(Params<0>::Type()), ParamTuple(), S_get(new StreamWriter(std::cerr)))); -const S& Var_error = *new S(new ExtValue_SimpleOutput(CreateType_SimpleOutput(Params<0>::Type()), ParamTuple(), S_get(new ErrorWriter()))); +const S& Var_stdout = *new S(new ExtValue_SimpleOutput(CreateType_SimpleOutput(Params<0>::Type()), S_get(new StreamWriter(std::cout)))); +const S& Var_stderr = *new S(new ExtValue_SimpleOutput(CreateType_SimpleOutput(Params<0>::Type()), S_get(new StreamWriter(std::cerr)))); +const S& Var_error = *new S(new ExtValue_SimpleOutput(CreateType_SimpleOutput(Params<0>::Type()), S_get(new ErrorWriter()))); } // namespace diff --git a/src/Cli/CompileOptions.hs b/src/Cli/CompileOptions.hs --- a/src/Cli/CompileOptions.hs +++ b/src/Cli/CompileOptions.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 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. @@ -33,6 +33,7 @@ isCompileFast, isCompileIncremental, isCompileRecompile, + isCompileUnspecified, isCreateTemplates, isExecuteTests, maybeDisableHelp, @@ -110,7 +111,8 @@ cfSource :: FilePath } | ExecuteTests { - etInclude :: [FilePath] + etInclude :: [FilePath], + etCallLog :: Maybe FilePath } | CompileIncremental { ciLinkFlags :: [String] @@ -139,12 +141,16 @@ isCompileRecompile _ = False isExecuteTests :: CompileMode -> Bool -isExecuteTests (ExecuteTests _) = True -isExecuteTests _ = False +isExecuteTests (ExecuteTests _ _) = True +isExecuteTests _ = False isCreateTemplates :: CompileMode -> Bool isCreateTemplates CreateTemplates = True isCreateTemplates _ = False + +isCompileUnspecified :: CompileMode -> Bool +isCompileUnspecified CompileUnspecified = True +isCompileUnspecified _ = False maybeDisableHelp :: HelpMode -> HelpMode maybeDisableHelp HelpUnspecified = HelpNotNeeded diff --git a/src/Cli/Compiler.hs b/src/Cli/Compiler.hs --- a/src/Cli/Compiler.hs +++ b/src/Cli/Compiler.hs @@ -281,8 +281,7 @@ mapCompilerM_ writeTemplate ts where generate testing tm n = do (_,t) <- getConcreteCategory tm ([],n) - let ctx = FileContext testing tm Set.empty Map.empty - generateStreamlinedTemplate ctx t + generateStreamlinedTemplate testing tm t writeTemplate (CxxOutput _ n _ _ _ content) = do let n' = p d n exists <- errorFromIO $ doesFileExist n' @@ -292,15 +291,16 @@ errorFromIO $ hPutStrLn stderr $ "Writing file " ++ n errorFromIO $ writeFile n' $ concat $ map (++ "\n") content -runModuleTests :: (PathIOHandler r, CompilerBackend b) => r -> b -> FilePath -> - [FilePath] -> LoadedTests -> TrackedErrorsIO [((Int,Int),TrackedErrors ())] -runModuleTests resolver backend base tp (LoadedTests p d m em deps1 deps2) = do +runModuleTests :: (PathIOHandler r, CompilerBackend b) => + r -> b -> FilePath -> FilePath -> [FilePath] -> LoadedTests -> + TrackedErrorsIO [((Int,Int),TrackedErrors ())] +runModuleTests resolver backend cl base tp (LoadedTests p d m em deps1 deps2) = do let paths = base:(cmPublicSubdirs m ++ cmPrivateSubdirs m ++ getIncludePathsForDeps deps1) mapCompilerM_ 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,NoNamespace) [] (Just m) deps1 [] - mapCompilerM (runSingleTest backend cm path paths (m:deps2)) ts' where + mapCompilerM (runSingleTest backend cl 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 = compilerWarningM $ "Skipping tests in " ++ f ++ " due to explicit test filter." diff --git a/src/Cli/ParseCompileOptions.hs b/src/Cli/ParseCompileOptions.hs --- a/src/Cli/ParseCompileOptions.hs +++ b/src/Cli/ParseCompileOptions.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 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. @@ -35,12 +35,12 @@ optionHelpText :: [String] optionHelpText = [ "", - "zeolite [options...] -m [category(.function)] -o [binary] [path]", - "zeolite [options...] --fast [category(.function)] [.0rx source]", "zeolite [options...] -c [path]", + "zeolite [options...] -m [category(.function)] (-o [binary]) [path]", + "zeolite [options...] --fast [category(.function)] [.0rx source]", "zeolite [options...] -r [paths...]", "zeolite [options...] -R [paths...]", - "zeolite [options...] -t [paths...]", + "zeolite [options...] -t [paths...] (--log-traces [filename])", "", "zeolite [options...] --templates [paths...]", "zeolite --get-path", @@ -48,8 +48,8 @@ "zeolite --version", "", "Normal Modes:", - " -c: Only compile the individual files. (default)", - " -m [category(.function)]: Create a binary that executes the function.", + " -c: Initialize and compile a new library module.", + " -m [category(.function)]: Initialize and compile a new binary module.", " --fast [category(.function)] [.0rx source]: Create a binary without needing a module.", " -r: Recompile using the previous compilation options.", " -R: Recursively recompile using the previous compilation options.", @@ -67,6 +67,7 @@ " -I [path]: A single source path to include as a *private* dependency.", " -o [binary]: The name of the binary file to create with -m.", " -p [path]: Set a path prefix for finding the specified source files.", + " --log-traces [filename]: Log call traces to a file when running tests.", "", "[category]: The name of a concrete category with no params.", "[function]: The name of a @type function (defaults to \"run\") with no args or params.", @@ -117,7 +118,7 @@ parseSingle (CompileOptions h is is2 ds es ep p m f) ((n,"-t"):os) | m /= CompileUnspecified = argError n "-t" "Compiler mode already set." - | otherwise = return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep p (ExecuteTests []) f) + | otherwise = return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep p (ExecuteTests [] Nothing) f) parseSingle (CompileOptions h is is2 ds es ep p m f) ((n,"--templates"):os) | m /= CompileUnspecified = argError n "-t" "Compiler mode already set." @@ -152,6 +153,13 @@ check _ = argError n2 c $ "Invalid entry point." update _ = argError n "--fast" "Requires a category name and a .0rx file." + parseSingle (CompileOptions h is is2 ds es ep p (ExecuteTests tp cl) f) ((n,"--log-traces"):os) = update os where + update ((_,cl2):os2) + | cl /= Nothing = argError n "--log-traces" "Trace-log filename already set." + | otherwise = return (os2,CompileOptions (maybeDisableHelp h) is is2 ds es ep p (ExecuteTests tp (Just cl2)) f) + update _ = argError n "--log-traces" "Requires an output filename." + parseSingle _ ((n,"--log-traces"):_) = argError n "--log-traces" "Set mode to test (-t) first." + parseSingle (CompileOptions h is is2 ds es ep p (CompileBinary t fn o lf) f) ((n,"-o"):os) | not $ null o = argError n "-o" "Output name already set." | otherwise = update os where @@ -159,7 +167,7 @@ checkPathName n2 o2 "-o" return (os2,CompileOptions (maybeDisableHelp h) is is2 ds es ep p (CompileBinary t fn o2 lf) f) update _ = argError n "-o" "Requires an output name." - parseSingle _ ((n,"-o"):_) = argError n "-o" "Set mode to binary (-m) first" + parseSingle _ ((n,"-o"):_) = argError n "-o" "Set mode to binary (-m) first." parseSingle (CompileOptions h is is2 ds es ep p m f) ((n,"-i"):os) = update os where update ((n2,d):os2) @@ -198,8 +206,8 @@ when (not $ isExecuteTests m) $ argError n d "Test mode (-t) must be enabled before listing any .0rt test files." checkPathName n d "" - let (ExecuteTests tp) = m - return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep p (ExecuteTests $ tp ++ [d]) f) + let (ExecuteTests tp cl) = m + return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep p (ExecuteTests (tp ++ [d]) cl) f) | otherwise = do checkPathName n d "" return (os,CompileOptions (maybeDisableHelp h) is is2 (ds ++ [d]) es ep p m f) @@ -207,6 +215,9 @@ validateCompileOptions :: CollectErrorsM m => CompileOptions -> m CompileOptions validateCompileOptions co@(CompileOptions h is is2 ds _ _ _ m _) | h /= HelpNotNeeded = return co + + | isCompileUnspecified m = + compilerErrorM "Compiler mode must be specified explicitly." | (not $ null $ is ++ is2) && (isExecuteTests m) = compilerErrorM "Include paths (-i/-I) are not allowed in test mode (-t)." diff --git a/src/Cli/RunCompiler.hs b/src/Cli/RunCompiler.hs --- a/src/Cli/RunCompiler.hs +++ b/src/Cli/RunCompiler.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 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. @@ -40,14 +40,22 @@ runCompiler :: (PathIOHandler r, CompilerBackend b) => r -> b -> CompileOptions -> TrackedErrorsIO () -runCompiler resolver backend (CompileOptions _ _ _ ds _ _ p (ExecuteTests tp) f) = do +runCompiler resolver backend (CompileOptions _ _ _ ds _ _ p (ExecuteTests tp cl) f) = do base <- resolveBaseModule resolver ts <- fmap snd $ foldM (preloadTests base) (Map.empty,[]) ds checkTestFilters ts - allResults <- fmap concat $ mapCompilerM (runModuleTests resolver backend base tp) ts + cl2 <- prepareCallLog cl + allResults <- fmap concat $ mapCompilerM (runModuleTests resolver backend cl2 base tp) ts let passed = sum $ map (fst . fst) allResults let failed = sum $ map (snd . fst) allResults processResults passed failed (mapCompilerM_ snd allResults) where + prepareCallLog (Just cl2) = do + clFull <- errorFromIO $ canonicalizePath (p cl2) + compilerWarningM $ "Logging calls to " ++ clFull + errorFromIO $ writeFile clFull (intercalate "," (map show logHeader) ++ "\n") + return clFull + prepareCallLog _ = return "" + logHeader = ["microseconds","pid","function","context"] compilerHash = getCompilerHash backend preloadTests base (ca,ms) d = do m <- loadModuleMetadata compilerHash f ca (p d) diff --git a/src/Cli/TestRunner.hs b/src/Cli/TestRunner.hs --- a/src/Cli/TestRunner.hs +++ b/src/Cli/TestRunner.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 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. @@ -47,10 +47,10 @@ import Types.TypeCategory -runSingleTest :: CompilerBackend b => b -> LanguageModule SourceContext -> - FilePath -> [FilePath] -> [CompileMetadata] -> (String,String) -> - TrackedErrorsIO ((Int,Int),TrackedErrors ()) -runSingleTest b cm p paths deps (f,s) = do +runSingleTest :: CompilerBackend b => b -> FilePath -> + LanguageModule SourceContext -> FilePath -> [FilePath] -> [CompileMetadata] -> + (String,String) -> TrackedErrorsIO ((Int,Int),TrackedErrors ()) +runSingleTest b cl cm p paths deps (f,s) = do errorFromIO $ hPutStrLn stderr $ "\nExecuting tests from " ++ f allResults <- checkAndRun (parseTestSource (f,s)) return $ second (("\nIn test file " ++ f) ??>) allResults where @@ -146,7 +146,7 @@ return results executeTest binary rs es res s2 (f2,c) = printOutcome $ "\nIn unittest " ++ show f2 ++ formatFullContextBrace c ??> do - let command = TestCommand binary (takeDirectory binary) [show f2] + let command = TestCommand binary (takeDirectory binary) [show f2,cl] (TestCommandResult s2' out err) <- runTestCommand b command case (s2,s2') of (True,False) -> collectAllM_ $ (asCompilerError res):(map compilerErrorM $ err ++ out) diff --git a/src/Compilation/CompilerState.hs b/src/Compilation/CompilerState.hs --- a/src/Compilation/CompilerState.hs +++ b/src/Compilation/CompilerState.hs @@ -27,7 +27,6 @@ CompilerContext(..), CompiledData(..), CompilerState, - ExpressionType, LoopSetup(..), JumpType(..), MemberValue(..), @@ -90,7 +89,6 @@ import Base.CompilerError import Base.GeneralType -import Base.Positional import Types.DefinedCategory import Types.Procedure import Types.TypeCategory @@ -110,7 +108,7 @@ ccGetRequired :: a -> m (Set.Set CategoryName) ccGetCategoryFunction :: a -> [c] -> Maybe CategoryName -> FunctionName -> m (ScopedFunction c) ccGetTypeFunction :: a -> [c] -> Maybe GeneralInstance -> FunctionName -> m (ScopedFunction c) - ccCheckValueInit :: a -> [c] -> TypeInstance -> ExpressionType -> Positional GeneralInstance -> m () + ccCheckValueInit :: a -> [c] -> TypeInstance -> ExpressionType -> m () ccGetVariable :: a -> UsedVariable c -> m (VariableValue c) ccAddVariable :: a -> UsedVariable c -> VariableValue c -> m a ccSetReadOnly :: a -> UsedVariable c -> m a @@ -139,8 +137,6 @@ ccSetNoTrace :: a -> Bool -> m a ccGetNoTrace :: a -> m Bool -type ExpressionType = Positional ValueType - data MemberValue c = MemberValue { mvContext :: [c], @@ -224,8 +220,8 @@ csGetTypeFunction c t n = fmap (\x -> ccGetTypeFunction x c t n) get >>= lift csCheckValueInit :: CompilerContext c m s a => - [c] -> TypeInstance -> ExpressionType -> Positional GeneralInstance -> CompilerState a m () -csCheckValueInit c t as ps = fmap (\x -> ccCheckValueInit x c t as ps) get >>= lift + [c] -> TypeInstance -> ExpressionType -> CompilerState a m () +csCheckValueInit c t as = fmap (\x -> ccCheckValueInit x c t as) get >>= lift csGetVariable :: CompilerContext c m s a => UsedVariable c -> CompilerState a m (VariableValue c) diff --git a/src/Compilation/ProcedureContext.hs b/src/Compilation/ProcedureContext.hs --- a/src/Compilation/ProcedureContext.hs +++ b/src/Compilation/ProcedureContext.hs @@ -29,7 +29,7 @@ updateReturnVariables, ) where -import Control.Monad (when) +import Control.Monad (foldM,when) import Lens.Micro hiding (mapped) import Lens.Micro.TH import Data.Maybe (fromJust,isJust) @@ -65,12 +65,10 @@ _pcScope :: SymbolScope, _pcType :: CategoryName, _pcExtParams :: Positional (ValueParam c), - _pcIntParams :: Positional (ValueParam c), _pcMembers :: [DefinedMember c], _pcCategories :: CategoryMap c, _pcAllFilters :: ParamFilters, _pcExtFilters :: [ParamFilter c], - _pcIntFilters :: [ParamFilter c], _pcParamScopes :: Map.Map ParamName SymbolScope, _pcFunctions :: Map.Map FunctionName (ScopedFunction c), _pcVariables :: Map.Map VariableName (VariableValue c), @@ -134,7 +132,7 @@ ccGetTypeFunction ctx c t n = do t' <- case ctx ^. pcScope of CategoryScope -> case t of - Nothing -> compilerErrorM $ "Category " ++ show t ++ + Nothing -> compilerErrorM $ "Category " ++ show (ctx ^. pcType) ++ " does not have a category function named " ++ show n ++ formatFullContextBrace c Just t0 -> return t0 @@ -190,7 +188,7 @@ compilerErrorM $ "Category " ++ show t2 ++ " does not have a type or value function named " ++ show n ++ formatFullContextBrace c - ccCheckValueInit ctx c (TypeInstance t as) ts ps + ccCheckValueInit ctx c (TypeInstance t as) ts | t /= ctx ^. pcType = compilerErrorM $ "Category " ++ show (ctx ^. pcType) ++ " cannot initialize values from " ++ show t ++ formatFullContextBrace c @@ -199,26 +197,12 @@ r <- ccResolver ctx allFilters <- ccAllFilters ctx pa <- fmap Map.fromList $ processPairs alwaysPair (fmap vpParam $ ctx ^. pcExtParams) as - pa2 <- fmap Map.fromList $ processPairs alwaysPair (fmap vpParam $ ctx ^. pcIntParams) ps - let pa' = Map.union pa pa2 - validateTypeInstance r allFilters t' - -- Check internal param substitution. - let mapped = Map.fromListWith (++) $ map (\f -> (pfParam f,[pfFilter f])) (ctx ^. pcIntFilters) - let positional = map (getFilters mapped) (map vpParam $ pValues $ ctx ^. pcIntParams) - assigned <- fmap Map.fromList $ processPairs alwaysPair (fmap vpParam $ ctx ^. pcIntParams) ps - subbed <- fmap Positional $ mapCompilerM (assignFilters assigned) positional - processPairs_ (validateAssignment r allFilters) ps subbed + validateTypeInstanceForCall r allFilters t' -- Check initializer types. - ms <- fmap Positional $ mapCompilerM (subSingle pa') (ctx ^. pcMembers) + ms <- fmap Positional $ mapCompilerM (subSingle pa) (ctx ^. pcMembers) processPairs_ (checkInit r allFilters) ms (Positional $ zip ([1..] :: [Int]) $ pValues ts) return () where - getFilters fm n = - case n `Map.lookup` fm of - (Just fs) -> fs - _ -> [] - assignFilters fm fs = do - mapCompilerM (uncheckedSubFilter $ getValueForParam fm) fs checkInit r fa (MemberValue c2 n t0) (i,t1) = do checkValueAssignment r fa t1 t0 + compilerErrorM $ "Variable " ++ show n ++ formatFullContextBrace c ++ + " is hidden" (Just (VariableValue _ _ _ (VariableHidden c2))) -> compilerErrorM $ "Variable " ++ show n ++ formatFullContextBrace c ++ " was explicitly hidden at " ++ formatFullContext c2 @@ -391,12 +378,12 @@ updateArgVariables ma as1 as2 = do as <- processPairs alwaysPair as1 (avNames as2) let as' = filter (not . isDiscardedInput . snd) as - foldr update (return ma) as' where - update (PassedValue c t,a) va = do - va' <- va - case ivName a `Map.lookup` va' of - Nothing -> return $ Map.insert (ivName a) (VariableValue c LocalScope t (VariableReadOnly c)) va' + foldM update ma as' where + update va (PassedValue _ t,a) = do + let c = ivContext a + case ivName a `Map.lookup` va of + Nothing -> return $ Map.insert (ivName a) (VariableValue c LocalScope t (VariableReadOnly c)) va (Just v) -> compilerErrorM $ "Variable " ++ show (ivName a) ++ - formatFullContextBrace (ivContext a) ++ - " is already defined" ++ - formatFullContextBrace (vvContext v) + formatFullContextBrace c ++ + " is already defined" ++ + formatFullContextBrace (vvContext v) diff --git a/src/Compilation/ScopeContext.hs b/src/Compilation/ScopeContext.hs --- a/src/Compilation/ScopeContext.hs +++ b/src/Compilation/ScopeContext.hs @@ -26,9 +26,8 @@ getProcedureScopes, ) where -import Control.Monad (when) -import Prelude hiding (pi) import qualified Data.Map as Map +import qualified Data.Set as Set import Base.CompilerError import Base.GeneralType @@ -44,11 +43,9 @@ ScopeContext { scCategories :: CategoryMap c, scName :: CategoryName, - scExternalParams :: Positional (ValueParam c), - scInternalparams :: Positional (ValueParam c), + scParams :: Positional (ValueParam c), scValueMembers :: [DefinedMember c], - scExternalFilters :: [ParamFilter c], - scInternalFilters :: [ParamFilter c], + scFilters :: [ParamFilter c], scFunctions :: Map.Map FunctionName (ScopedFunction c), scVariables :: Map.Map VariableName (VariableValue c), scExprMap :: ExprMap c @@ -66,17 +63,13 @@ getProcedureScopes :: (Show c, CollectErrorsM m) => CategoryMap c -> ExprMap c -> DefinedCategory c -> m [ProcedureScope c] -getProcedureScopes ta em (DefinedCategory c n pi _ _ fi ms ps fs) = do +getProcedureScopes ta em (DefinedCategory c n pragmas _ _ 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 filters = getCategoryFilters t - let filters2 = fi let r = CategoryResolver ta fa <- setInternalFunctions r t fs - 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 tp' <- mapCompilerM (firstM $ replaceSelfFunction (instanceFromCategory t)) tp @@ -87,39 +80,35 @@ let cm0 = builtins typeInstance CategoryScope let tm0 = builtins typeInstance TypeScope let vm0 = builtins typeInstance ValueScope - cm2 <- mapMembers cm - tm2 <- mapMembers $ cm ++ tm' - vm2 <- mapMembers $ cm ++ tm' ++ vm' + cm2 <- mapMembers readOnly hidden cm + tm2 <- mapMembers readOnly hidden $ cm ++ tm' + vm2 <- mapMembers readOnly hidden $ cm ++ tm' ++ vm' + mapCompilerM_ checkPragma pragmas let cv = Map.union cm0 cm2 let tv = Map.union tm0 tm2 let vv = Map.union vm0 vm2 - let ctxC = ScopeContext ta n params params2 vm' filters filters2 fa cv em - let ctxT = ScopeContext ta n params params2 vm' filters filters2 fa tv em - let ctxV = ScopeContext ta n params params2 vm' filters filters2 fa vv em + let ctxC = ScopeContext ta n params vm' filters fa cv em + let ctxT = ScopeContext ta n params vm' filters fa tv em + let ctxV = ScopeContext ta n params vm' filters fa vv em return [ProcedureScope ctxC cp,ProcedureScope ctxT tp',ProcedureScope ctxV vp'] where + checkPragma (MembersReadOnly c2 vs) = do + let missing = Set.toList $ Set.fromList vs `Set.difference` allMembers + mapCompilerM_ (\v -> compilerErrorM $ "Member " ++ show v ++ + " does not exist (marked ReadOnly at " ++ + formatFullContext c2 ++ ")") missing + checkPragma (MembersHidden c2 vs) = do + let missing = Set.toList $ Set.fromList vs `Set.difference` allMembers + mapCompilerM_ (\v -> compilerErrorM $ "Member " ++ show v ++ + " does not exist (marked Hidden at " ++ + formatFullContext c2 ++ ")") missing + allMembers = Set.fromList $ map dmName ms + readOnly = Map.fromListWith (++) $ concat $ map (\m -> zip (mroMembers m) (repeat $ mroContext m)) $ filter isMembersReadOnly pragmas + hidden = Map.fromListWith (++) $ concat $ map (\m -> zip (mhMembers m) (repeat $ mhContext m)) $ filter isMembersHidden pragmas firstM f (x,y) = do x' <- f x return (x',y) 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 - mapCompilerM_ (checkFunction pm) fs2 - mapCompilerM_ (checkParam pm) pe - fa' <- fmap (Map.union fa) $ getFilterMap pi2 fi2 - mapCompilerM_ (checkFilter r fa') fi2 - checkFilter r fa (ParamFilter c2 n2 f) = - validateTypeFilter r fa f return () - (Just c2) -> compilerErrorM $ "Internal param " ++ show (vpParam p) ++ - formatFullContextBrace (vpContext p) ++ - " is already defined at " ++ - formatFullContext c2 -- TODO: This is probably in the wrong module. builtinVariables :: TypeInstance -> Map.Map VariableName (VariableValue c) diff --git a/src/CompilerCxx/CategoryContext.hs b/src/CompilerCxx/CategoryContext.hs --- a/src/CompilerCxx/CategoryContext.hs +++ b/src/CompilerCxx/CategoryContext.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 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. @@ -34,7 +34,7 @@ import Compilation.CompilerState import Compilation.ProcedureContext import Compilation.ScopeContext -import CompilerCxx.Code +import Types.Builtin import Types.DefinedCategory import Types.Procedure import Types.TypeCategory @@ -57,17 +57,16 @@ 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) + let readOnly = Map.fromListWith (++) $ map (\m -> (dmName m,[])) $ dcMembers d + members <- mapMembers readOnly Map.empty $ filter ((<= s) . dmScope) (dcMembers d) return $ ProcedureContext { _pcScope = s, _pcType = getCategoryName t, _pcExtParams = ps, - _pcIntParams = Positional [], _pcMembers = ms, _pcCategories = tm, _pcAllFilters = fm, _pcExtFilters = pa, - _pcIntFilters = [], _pcParamScopes = sa, _pcFunctions = fa, _pcVariables = Map.union builtin members, @@ -89,7 +88,7 @@ getProcedureContext :: (Show c, CollectErrorsM m) => ScopeContext c -> ScopedFunction c -> ExecutableProcedure c -> m (ProcedureContext c) -getProcedureContext (ScopeContext tm t ps pi ms pa fi fa va em) +getProcedureContext (ScopeContext tm t ps ms pa fa va em) ff@(ScopedFunction _ _ _ s as1 rs1 ps1 fs _) (ExecutableProcedure _ _ _ _ as2 rs2 _) = do rs' <- if isUnnamedReturns rs2 @@ -102,35 +101,30 @@ else pa ++ fs let localScopes = Map.fromList $ zip (map vpParam $ pValues ps1) (repeat LocalScope) let typeScopes = Map.fromList $ zip (map vpParam $ pValues ps) (repeat TypeScope) - let valueScopes = Map.fromList $ zip (map vpParam $ pValues pi) (repeat ValueScope) let sa = case s of CategoryScope -> localScopes - TypeScope -> Map.union typeScopes localScopes - ValueScope -> Map.unions [localScopes,typeScopes,valueScopes] + TypeScope -> Map.union typeScopes localScopes + ValueScope -> Map.union typeScopes localScopes _ -> undefined 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 - ValueScope -> Map.unions [localFilters,typeFilters,valueFilters] + TypeScope -> Map.union localFilters typeFilters + ValueScope -> Map.union localFilters typeFilters _ -> undefined let ns0 = if isUnnamedReturns rs2 then [] else zipWith3 ReturnVariable [0..] (map ovName $ pValues $ nrNames rs2) (map pvType $ pValues rs1) - let ns = filter (isPrimType . rvType) ns0 + let ns = filter (isPrimitiveType . rvType) ns0 return $ ProcedureContext { _pcScope = s, _pcType = t, _pcExtParams = ps, - _pcIntParams = pi, _pcMembers = ms, _pcCategories = tm, _pcAllFilters = allFilters, _pcExtFilters = pa', - -- fs is duplicated so value initialization checks work properly. - _pcIntFilters = fi ++ fs, _pcParamScopes = sa, _pcFunctions = fa, _pcVariables = va'', @@ -157,12 +151,10 @@ _pcScope = LocalScope, _pcType = CategoryNone, _pcExtParams = Positional [], - _pcIntParams = Positional [], _pcMembers = [], _pcCategories = tm, _pcAllFilters = Map.empty, _pcExtFilters = [], - _pcIntFilters = [], _pcParamScopes = Map.empty, _pcFunctions = Map.empty, _pcVariables = Map.empty, diff --git a/src/CompilerCxx/Code.hs b/src/CompilerCxx/Code.hs --- a/src/CompilerCxx/Code.hs +++ b/src/CompilerCxx/Code.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 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. @@ -19,8 +19,6 @@ {-# LANGUAGE Safe #-} module CompilerCxx.Code ( - ExprValue(..), - PrimitiveType(..), categoryBase, captureCreationTrace, clearCompiled, @@ -29,7 +27,6 @@ escapeChars, functionLabelType, indentCompiled, - isPrimType, newFunctionLabel, noTestsOnlySourceGuard, onlyCode, @@ -88,8 +85,8 @@ clearCompiled :: CompiledData [String] -> CompiledData [String] clearCompiled (CompiledData r _) = CompiledData r [] -startFunctionTracing :: ScopedFunction c -> String -startFunctionTracing f = "TRACE_FUNCTION(" ++ show (functionDebugName f) ++ ")" +startFunctionTracing :: CategoryName -> ScopedFunction c -> String +startFunctionTracing t f = "TRACE_FUNCTION(" ++ show (functionDebugName t f) ++ ")" startMainTracing :: String -> String startMainTracing n = "TRACE_FUNCTION(" ++ show n ++ ")" @@ -113,38 +110,13 @@ | null c = "" | otherwise = "PRED_CONTEXT_POINT(" ++ escapeChars (formatFullContext c) ++ ")" -captureCreationTrace :: String -captureCreationTrace = "CAPTURE_CREATION" +captureCreationTrace :: CategoryName -> String +captureCreationTrace n = "CAPTURE_CREATION(" ++ show (show n) ++ ")" showCreationTrace :: String showCreationTrace = "TRACE_CREATION" -data PrimitiveType = - PrimBool | - PrimString | - PrimChar | - PrimInt | - PrimFloat - deriving (Eq,Show) - -isPrimType :: ValueType -> Bool -isPrimType t - | t == boolRequiredValue = True - | t == intRequiredValue = True - | t == floatRequiredValue = True - | t == charRequiredValue = True - | otherwise = False - -data ExprValue = - OpaqueMulti String | - WrappedSingle String | - UnwrappedSingle String | - BoxedPrimitive PrimitiveType String | - UnboxedPrimitive PrimitiveType String | - LazySingle ExprValue - deriving (Show) - -getFromLazy :: ExprValue -> ExprValue +getFromLazy :: ExpressionValue -> ExpressionValue getFromLazy (OpaqueMulti e) = OpaqueMulti $ e ++ ".Get()" getFromLazy (WrappedSingle e) = WrappedSingle $ e ++ ".Get()" getFromLazy (UnwrappedSingle e) = UnwrappedSingle $ e ++ ".Get()" @@ -152,7 +124,7 @@ getFromLazy (UnboxedPrimitive t e) = UnboxedPrimitive t $ e ++ ".Get()" getFromLazy (LazySingle e) = LazySingle $ getFromLazy e -useAsWhatever :: ExprValue -> String +useAsWhatever :: ExpressionValue -> String useAsWhatever (OpaqueMulti e) = e useAsWhatever (WrappedSingle e) = e useAsWhatever (UnwrappedSingle e) = e @@ -160,7 +132,7 @@ useAsWhatever (UnboxedPrimitive _ e) = e useAsWhatever (LazySingle e) = useAsWhatever $ getFromLazy e -useAsReturns :: ExprValue -> String +useAsReturns :: ExpressionValue -> String useAsReturns (OpaqueMulti e) = "(" ++ e ++ ")" useAsReturns (WrappedSingle e) = "ReturnTuple(" ++ e ++ ")" useAsReturns (UnwrappedSingle e) = "ReturnTuple(" ++ e ++ ")" @@ -176,7 +148,7 @@ useAsReturns (UnboxedPrimitive PrimFloat e) = "ReturnTuple(Box_Float(" ++ e ++ "))" useAsReturns (LazySingle e) = useAsReturns $ getFromLazy e -useAsArgs :: ExprValue -> String +useAsArgs :: ExpressionValue -> String useAsArgs (OpaqueMulti e) = "(" ++ e ++ ")" useAsArgs (WrappedSingle e) = "ArgTuple(" ++ e ++ ")" useAsArgs (UnwrappedSingle e) = "ArgTuple(" ++ e ++ ")" @@ -192,7 +164,7 @@ useAsArgs (UnboxedPrimitive PrimFloat e) = "ArgTuple(Box_Float(" ++ e ++ "))" useAsArgs (LazySingle e) = useAsArgs $ getFromLazy e -useAsUnwrapped :: ExprValue -> String +useAsUnwrapped :: ExpressionValue -> String useAsUnwrapped (OpaqueMulti e) = "(" ++ e ++ ").Only()" useAsUnwrapped (WrappedSingle e) = "(" ++ e ++ ")" useAsUnwrapped (UnwrappedSingle e) = "(" ++ e ++ ")" @@ -203,32 +175,32 @@ useAsUnwrapped (BoxedPrimitive PrimFloat e) = "Box_Float(" ++ e ++ ")" useAsUnwrapped (UnboxedPrimitive PrimBool e) = "Box_Bool(" ++ e ++ ")" useAsUnwrapped (UnboxedPrimitive PrimString e) = "Box_String(" ++ e ++ ")" -useAsUnwrapped (UnboxedPrimitive PrimChar e) = "Box_Char(" ++ e ++ ")" +useAsUnwrapped (UnboxedPrimitive PrimChar e) = "Box_Char(" ++ e ++ ")" useAsUnwrapped (UnboxedPrimitive PrimInt e) = "Box_Int(" ++ e ++ ")" useAsUnwrapped (UnboxedPrimitive PrimFloat e) = "Box_Float(" ++ e ++ ")" useAsUnwrapped (LazySingle e) = useAsUnwrapped $ getFromLazy e -useAsUnboxed :: PrimitiveType -> ExprValue -> String -useAsUnboxed PrimBool (OpaqueMulti e) = "(" ++ e ++ ").Only()->AsBool()" -useAsUnboxed PrimString (OpaqueMulti e) = "(" ++ e ++ ").Only()->AsString()" -useAsUnboxed PrimChar (OpaqueMulti e) = "(" ++ e ++ ").Only()->AsChar()" -useAsUnboxed PrimInt (OpaqueMulti e) = "(" ++ e ++ ").Only()->AsInt()" -useAsUnboxed PrimFloat (OpaqueMulti e) = "(" ++ e ++ ").Only()->AsFloat()" -useAsUnboxed PrimBool (WrappedSingle e) = "(" ++ e ++ ")->AsBool()" -useAsUnboxed PrimString (WrappedSingle e) = "(" ++ e ++ ")->AsString()" -useAsUnboxed PrimChar (WrappedSingle e) = "(" ++ e ++ ")->AsChar()" -useAsUnboxed PrimInt (WrappedSingle e) = "(" ++ e ++ ")->AsInt()" -useAsUnboxed PrimFloat (WrappedSingle e) = "(" ++ e ++ ")->AsFloat()" +useAsUnboxed :: PrimitiveType -> ExpressionValue -> String +useAsUnboxed PrimBool (OpaqueMulti e) = "(" ++ e ++ ").Only()->AsBool()" +useAsUnboxed PrimString (OpaqueMulti e) = "(" ++ e ++ ").Only()->AsString()" +useAsUnboxed PrimChar (OpaqueMulti e) = "(" ++ e ++ ").Only()->AsChar()" +useAsUnboxed PrimInt (OpaqueMulti e) = "(" ++ e ++ ").Only()->AsInt()" +useAsUnboxed PrimFloat (OpaqueMulti e) = "(" ++ e ++ ").Only()->AsFloat()" +useAsUnboxed PrimBool (WrappedSingle e) = "(" ++ e ++ ")->AsBool()" +useAsUnboxed PrimString (WrappedSingle e) = "(" ++ e ++ ")->AsString()" +useAsUnboxed PrimChar (WrappedSingle e) = "(" ++ e ++ ")->AsChar()" +useAsUnboxed PrimInt (WrappedSingle e) = "(" ++ e ++ ")->AsInt()" +useAsUnboxed PrimFloat (WrappedSingle e) = "(" ++ e ++ ")->AsFloat()" useAsUnboxed PrimBool (UnwrappedSingle e) = "(" ++ e ++ ")->AsBool()" useAsUnboxed PrimString (UnwrappedSingle e) = "(" ++ e ++ ")->AsString()" useAsUnboxed PrimChar (UnwrappedSingle e) = "(" ++ e ++ ")->AsChar()" useAsUnboxed PrimInt (UnwrappedSingle e) = "(" ++ e ++ ")->AsInt()" useAsUnboxed PrimFloat (UnwrappedSingle e) = "(" ++ e ++ ")->AsFloat()" -useAsUnboxed _ (BoxedPrimitive _ e) = "(" ++ e ++ ")" -useAsUnboxed _ (UnboxedPrimitive _ e) = "(" ++ e ++ ")" -useAsUnboxed t (LazySingle e) = useAsUnboxed t $ getFromLazy e +useAsUnboxed _ (BoxedPrimitive _ e) = "(" ++ e ++ ")" +useAsUnboxed _ (UnboxedPrimitive _ e) = "(" ++ e ++ ")" +useAsUnboxed t (LazySingle e) = useAsUnboxed t $ getFromLazy e -valueAsWrapped :: ExprValue -> ExprValue +valueAsWrapped :: ExpressionValue -> ExpressionValue valueAsWrapped (UnwrappedSingle e) = WrappedSingle e valueAsWrapped (BoxedPrimitive _ e) = WrappedSingle e valueAsWrapped (UnboxedPrimitive PrimBool e) = WrappedSingle $ "Box_Bool(" ++ e ++ ")" @@ -239,7 +211,7 @@ valueAsWrapped (LazySingle e) = valueAsWrapped $ getFromLazy e valueAsWrapped v = v -valueAsUnwrapped :: ExprValue -> ExprValue +valueAsUnwrapped :: ExpressionValue -> ExpressionValue valueAsUnwrapped (OpaqueMulti e) = UnwrappedSingle $ "(" ++ e ++ ").Only()" valueAsUnwrapped (WrappedSingle e) = UnwrappedSingle e valueAsUnwrapped (UnboxedPrimitive PrimBool e) = UnwrappedSingle $ "Box_Bool(" ++ e ++ ")" @@ -271,21 +243,21 @@ | isWeakValue t = "W&" | otherwise = "S&" -readStoredVariable :: Bool -> ValueType -> String -> ExprValue +readStoredVariable :: Bool -> ValueType -> String -> ExpressionValue readStoredVariable True t s = LazySingle $ readStoredVariable False t s readStoredVariable False t s - | t == boolRequiredValue = UnboxedPrimitive PrimBool s - | t == intRequiredValue = UnboxedPrimitive PrimInt s + | t == boolRequiredValue = UnboxedPrimitive PrimBool s + | t == intRequiredValue = UnboxedPrimitive PrimInt s | t == floatRequiredValue = UnboxedPrimitive PrimFloat s - | t == charRequiredValue = UnboxedPrimitive PrimChar s + | t == charRequiredValue = UnboxedPrimitive PrimChar s | otherwise = UnwrappedSingle s -writeStoredVariable :: ValueType -> ExprValue -> String +writeStoredVariable :: ValueType -> ExpressionValue -> String writeStoredVariable t e - | t == boolRequiredValue = useAsUnboxed PrimBool e - | t == intRequiredValue = useAsUnboxed PrimInt e + | t == boolRequiredValue = useAsUnboxed PrimBool e + | t == intRequiredValue = useAsUnboxed PrimInt e | t == floatRequiredValue = useAsUnboxed PrimFloat e - | t == charRequiredValue = useAsUnboxed PrimChar e + | t == charRequiredValue = useAsUnboxed PrimChar e | otherwise = useAsUnwrapped e functionLabelType :: ScopedFunction c -> String diff --git a/src/CompilerCxx/CxxFiles.hs b/src/CompilerCxx/CxxFiles.hs --- a/src/CompilerCxx/CxxFiles.hs +++ b/src/CompilerCxx/CxxFiles.hs @@ -87,17 +87,17 @@ return (dec:def) generateNativeInterface :: (Ord c, Show c, CollectErrorsM m) => - Bool -> AnyCategory c -> m [CxxOutput] -generateNativeInterface testing t = do - dec <- compileCategoryDeclaration testing Set.empty t + Bool -> Set.Set Namespace -> AnyCategory c -> m [CxxOutput] +generateNativeInterface testing ns t = do + dec <- compileCategoryDeclaration testing ns t def <- generateCategoryDefinition testing (NativeInterface t) return (dec:def) generateStreamlinedExtension :: (Ord c, Show c, CollectErrorsM m) => - Bool -> AnyCategory c -> m [CxxOutput] -generateStreamlinedExtension testing t = do - dec <- compileCategoryDeclaration testing Set.empty t - def <- generateCategoryDefinition testing (StreamlinedExtension t) + Bool -> Set.Set Namespace -> AnyCategory c -> m [CxxOutput] +generateStreamlinedExtension testing ns t = do + dec <- compileCategoryDeclaration testing ns t + def <- generateCategoryDefinition testing (StreamlinedExtension t ns) return (dec:def) generateVerboseExtension :: (Ord c, Show c, CollectErrorsM m) => @@ -106,8 +106,8 @@ fmap (:[]) $ compileCategoryDeclaration testing Set.empty t generateStreamlinedTemplate :: (Ord c, Show c, CollectErrorsM m) => - FileContext c -> AnyCategory c -> m [CxxOutput] -generateStreamlinedTemplate (FileContext testing tm _ _) t = + Bool -> CategoryMap c -> AnyCategory c -> m [CxxOutput] +generateStreamlinedTemplate testing tm t = generateCategoryDefinition testing (StreamlinedTemplate t tm) compileCategoryDeclaration :: (Ord c, Show c, CollectErrorsM m) => @@ -160,7 +160,8 @@ ncExprMap :: ExprMap c } | StreamlinedExtension { - seCategory :: AnyCategory c + seCategory :: AnyCategory c, + ncNamespaces :: Set.Set Namespace } | StreamlinedTemplate { stCategory :: AnyCategory c, @@ -192,32 +193,21 @@ (Set.fromList [getCategoryNamespace t]) req' (allowTestsOnly $ addSourceIncludes $ addCategoryHeader t $ addIncludes req' out) - common (StreamlinedExtension t) = sequence [streamlinedHeader,streamlinedSource] where + common (StreamlinedExtension t ns) = sequence [streamlinedHeader,streamlinedSource] where streamlinedHeader = do let filename = headerStreamlined (getCategoryName t) (CompiledData req out) <- fmap (addNamespace t) $ concatM [ defineAbstractCategory t, defineAbstractType t, - defineAbstractValue t defined, + defineAbstractValue t, declareAbstractGetters t ] return $ CxxOutput (Just $ getCategoryName t) filename (getCategoryNamespace t) - (Set.fromList [getCategoryNamespace t]) + (getCategoryNamespace t `Set.insert` ns) req (headerGuard (getCategoryName t) $ allowTestsOnly $ addSourceIncludes $ addCategoryHeader t $ addIncludes req out) - defined = DefinedCategory { - dcContext = [], - dcName = getCategoryName t, - dcParams = [], - dcRefines = [], - dcDefines = [], - dcParamFilter = [], - dcMembers = [], - dcProcedures = [], - dcFunctions = [] - } streamlinedSource = do let filename = sourceStreamlined (getCategoryName t) let (cf,tf,vf) = partitionByScope sfScope $ getCategoryFunctions t @@ -232,7 +222,7 @@ return $ CxxOutput (Just $ getCategoryName t) filename (getCategoryNamespace t) - (Set.fromList [getCategoryNamespace t]) + (getCategoryNamespace t `Set.insert` ns) req' (addSourceIncludes $ addStreamlinedHeader t $ addIncludes req' out) common (StreamlinedTemplate t tm) = fmap (:[]) streamlinedTemplate where @@ -256,11 +246,10 @@ filename = templateStreamlined (getCategoryName t) defined = DefinedCategory { dcContext = [], + dcPragmas = [], dcName = getCategoryName t, - dcParams = [], dcRefines = [], dcDefines = [], - dcParamFilter = [], dcMembers = [], dcProcedures = map defaultFail (getCategoryFunctions t), dcFunctions = [] @@ -276,12 +265,12 @@ } createArg = InputValue [] . VariableName . ("arg" ++) . show failProcedure f = Procedure [] $ [ - asLineComment $ "TODO: Implement " ++ functionDebugName f ++ "." + asLineComment $ "TODO: Implement " ++ functionDebugName (getCategoryName t) f ++ "." ] ++ map asLineComment (formatFunctionTypes f) ++ [ - RawFailCall (functionDebugName f ++ " is not implemented (see " ++ filename ++ ")") + RawFailCall (functionDebugName (getCategoryName t) f ++ " is not implemented (see " ++ filename ++ ")") ] asLineComment = NoValueExpression [] . LineComment - common (NativeConcrete t d@(DefinedCategory _ _ pi _ _ fi ms _ _) ta ns em) = fmap (:[]) singleSource where + common (NativeConcrete t d@(DefinedCategory _ _ _ _ _ ms _ _) ta ns em) = fmap (:[]) singleSource where singleSource = do let filename = sourceFilename (getCategoryName t) ta' <- mergeInternalInheritance ta d @@ -289,18 +278,16 @@ [cp,tp,vp] <- getProcedureScopes ta' em d let (_,tm,_) = partitionByScope dmScope ms disallowTypeMembers tm - let filters = getCategoryFilters t - let filters2 = fi - allFilters <- getFilterMap (getCategoryParams t ++ pi) $ filters ++ filters2 + params <- getCategoryParamSet t let cf = map fst $ psProcedures cp let tf = map fst $ psProcedures tp let vf = map fst $ psProcedures vp (CompiledData req out) <- fmap (addNamespace t) $ concatM [ defineFunctions t cf tf vf, declareInternalGetters t, - defineConcreteCategory r allFilters cf ta' em t d, + defineConcreteCategory r cf ta' em t d, defineConcreteType tf t, - defineConcreteValue r allFilters vf t d, + defineConcreteValue r params vf t d, defineCategoryOverrides t cf, defineTypeOverrides t tf, defineValueOverrides t vf, @@ -385,17 +372,18 @@ return $ onlyCode $ "struct " ++ typeName (getCategoryName t) ++ " : public " ++ typeBase ++ " {", fmap indentCompiled $ inlineTypeConstructor t, return declareTypeOverrides, + return $ declareTypeArgGetters t, return $ indentCompiled $ createParams $ getCategoryParams t, return $ onlyCode $ " " ++ categoryName (getCategoryName t) ++ "& parent;", return $ onlyCode "};" ] - defineConcreteCategory r allFilters fs tm em t d = concatM [ + defineConcreteCategory r fs tm em t d = concatM [ return $ onlyCode $ "struct " ++ categoryName (getCategoryName t) ++ " : public " ++ categoryBase ++ " {", fmap indentCompiled $ inlineCategoryConstructor t d tm em, return declareCategoryOverrides, fmap indentCompiled $ concatM $ map (procedureDeclaration False) fs, - fmap indentCompiled $ concatM $ map (createMemberLazy r allFilters) members, + fmap indentCompiled $ concatM $ map (createMemberLazy r) members, return $ onlyCode "};" ] where members = filter ((== CategoryScope). dmScope) $ dcMembers d @@ -403,18 +391,18 @@ return $ onlyCode $ "struct " ++ typeName (getCategoryName t) ++ " : public " ++ typeBase ++ " {", fmap indentCompiled $ inlineTypeConstructor t, return declareTypeOverrides, + return $ declareTypeArgGetters t, fmap indentCompiled $ concatM $ map (procedureDeclaration False) fs, return $ indentCompiled $ createParams $ getCategoryParams t, return $ onlyCode $ " " ++ categoryName (getCategoryName t) ++ "& parent;", return $ onlyCode "};" ] - defineConcreteValue r allFilters fs t d = concatM [ + defineConcreteValue r params fs t d = concatM [ return $ onlyCode $ "struct " ++ valueName (getCategoryName t) ++ " : public " ++ valueBase ++ " {", fmap indentCompiled $ inlineValueConstructor t d, return declareValueOverrides, fmap indentCompiled $ concatM $ map (procedureDeclaration False) fs, - fmap indentCompiled $ concatM $ map (createMember r allFilters t) members, - return $ indentCompiled $ createParams $ dcParams d, + fmap indentCompiled $ concatM $ map (createMember r params t) members, return $ onlyCode $ " const S<" ++ typeName (getCategoryName t) ++ "> parent;", return $ onlyCodes traceCreation, return $ onlyCode "};" @@ -422,7 +410,7 @@ members = filter ((== ValueScope). dmScope) $ dcMembers d procedures = dcProcedures d traceCreation - | any isTraceCreation $ concat $ map epPragmas procedures = [captureCreationTrace] + | any isTraceCreation $ concat $ map epPragmas procedures = [captureCreationTrace $ getCategoryName t] | otherwise = [] defineAbstractCategory t = concatM [ @@ -436,15 +424,16 @@ return $ onlyCode $ "struct " ++ typeName (getCategoryName t) ++ " : public " ++ typeBase ++ " {", fmap indentCompiled $ inlineTypeConstructor t, return declareTypeOverrides, + return $ declareTypeArgGetters t, fmap indentCompiled $ concatM $ map (procedureDeclaration True) $ filter ((== TypeScope). sfScope) $ getCategoryFunctions t, return $ onlyCode $ " virtual inline ~" ++ typeName (getCategoryName t) ++ "() {}", return $ indentCompiled $ createParams $ getCategoryParams t, return $ onlyCode $ " " ++ categoryName (getCategoryName t) ++ "& parent;", return $ onlyCode "};" ] - defineAbstractValue t d = concatM [ + defineAbstractValue t = concatM [ return $ onlyCode $ "struct " ++ valueName (getCategoryName t) ++ " : public " ++ valueBase ++ " {", - fmap indentCompiled $ abstractValueConstructor t d, + fmap indentCompiled $ abstractValueConstructor t, return declareValueOverrides, fmap indentCompiled $ concatM $ map (procedureDeclaration True) $ filter ((== ValueScope). sfScope) $ getCategoryFunctions t, return $ onlyCode $ " virtual inline ~" ++ valueName (getCategoryName t) ++ "() {}", @@ -511,6 +500,7 @@ onlyCode $ "bool " ++ className ++ "::TypeArgsForParent(const TypeCategory& category, std::vector>& args) const {", createTypeArgsForParent t, onlyCode $ "}", + defineTypeArgGetters t, onlyCode $ "ReturnTuple " ++ className ++ "::Dispatch(const S& self, const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) {", createFunctionDispatch (getCategoryName t) TypeScope fs, onlyCode $ "}", @@ -528,13 +518,13 @@ ] where className = valueName (getCategoryName t) - createMember r filters t m = do + createMember r params t m = do m' <- replaceSelfMember (instanceFromCategory t) m - validateGeneralInstance r filters (vtType $ dmType m') p" - let paramsPassed = "const ParamTuple& params" let argsPassed = "const ValueTuple& args" - let allArgs = intercalate ", " [argParent,paramsPassed,argsPassed] + let allArgs = intercalate ", " [argParent,argsPassed] let initParent = "parent(p)" - let initParams = map (\(i,p) -> paramName (vpParam p) ++ "(params.At(" ++ show i ++ "))") $ zip ([0..] :: [Int]) $ dcParams d let initArgs = map (\(i,m) -> variableName (dmName m) ++ "(" ++ unwrappedArg i m ++ ")") $ zip ([0..] :: [Int]) members - let allInit = intercalate ", " $ initParent:(initParams ++ initArgs) + let allInit = intercalate ", " $ initParent:initArgs return $ onlyCode $ "inline " ++ valueName (getCategoryName t) ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" where unwrappedArg i m = writeStoredVariable (dmType m) (UnwrappedSingle $ "args.At(" ++ show i ++ ")") members = filter ((== ValueScope). dmScope) $ dcMembers d - abstractValueConstructor t d = do + abstractValueConstructor t = do let argParent = "S<" ++ typeName (getCategoryName t) ++ "> p" - let paramsPassed = "const ParamTuple& params" - let allArgs = intercalate ", " [argParent,paramsPassed] + let allArgs = intercalate ", " [argParent] let initParent = "parent(p)" - let initParams = map (\(i,p) -> paramName (vpParam p) ++ "(params.At(" ++ show i ++ "))") $ zip ([0..] :: [Int]) $ dcParams d - let allInit = intercalate ", " $ initParent:initParams + let allInit = initParent return $ onlyCode $ "inline " ++ valueName (getCategoryName t) ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" customTypeConstructor t = do @@ -599,10 +585,9 @@ return $ onlyCode $ "inline " ++ typeCustom (getCategoryName t) ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" customValueConstructor t = do let argParent = "S<" ++ typeName (getCategoryName t) ++ "> p" - let paramsPassed = "const ParamTuple& params" let argsPassed = "const ValueTuple& args" - let allArgs = intercalate ", " [argParent,paramsPassed,argsPassed] - let allInit = valueName (getCategoryName t) ++ "(p, params)" + let allArgs = intercalate ", " [argParent,argsPassed] + let allInit = valueName (getCategoryName t) ++ "(p)" return $ onlyCode $ "inline " ++ valueCustom (getCategoryName t) ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" allowTestsOnly @@ -664,13 +649,14 @@ ts' <- fmap mconcat $ mapCompilerM (compileTestProcedure tm em) ts (include,sel) <- selectTestFromArgv1 $ map tpName ts let (CompiledData req _) = ts' <> sel - let file = testsOnlySourceGuard ++ createMainCommon "testcase" (onlyCodes include <> ts') (argv <> sel) + let file = testsOnlySourceGuard ++ createMainCommon "testcase" (onlyCodes include <> ts') (argv <> callLog <> sel) return $ CompiledData req file where args' = map escapeChars args argv = onlyCodes [ "const char* argv2[] = { \"testcase\" " ++ concat (map (", " ++) args') ++ " };", "ProgramArgv program_argv(sizeof argv2 / sizeof(char*), argv2);" ] + callLog = onlyCode "LogCallsToFile call_logger_((argc < 3)? \"\" : argv[2]);" addNamespace :: AnyCategory c -> CompiledData [String] -> CompiledData [String] addNamespace t cs @@ -709,8 +695,7 @@ createFunctionDispatch :: CategoryName -> SymbolScope -> [ScopedFunction c] -> CompiledData [String] createFunctionDispatch n s fs = onlyCodes $ [typedef] ++ concat (map table $ byCategory) ++ - concat (map dispatch $ byCategory) ++ - [fallback] where + metaTable ++ select where filtered = filter ((== s) . sfScope) fs flatten f = f:(concat $ map flatten $ sfMerges f) flattened = concat $ map flatten filtered @@ -732,13 +717,20 @@ [" static const CallType " ++ tableName n2 ++ "[] = {"] ++ map (\f -> " &" ++ name f ++ ",") (Set.toList $ Set.fromList $ map sfName fs2) ++ [" };"] - dispatch (n2,_) = [ - " if (label.collection == " ++ collectionName n2 ++ ") {", - " if (label.function_num < 0 || label.function_num >= sizeof " ++ tableName n2 ++ " / sizeof(CallType)) {", + metaTable = [" static DispatchTable all_tables[] = {"] ++ + map dispatchKeyValue byCategory ++ + [" DispatchTable(),"," };"] + dispatchKeyValue (n2,_) = " DispatchTable(" ++ collectionName n2 ++ ", " ++ tableName n2 ++ ")," + select = [ + " const DispatchTable* const table = DispatchSelect(label.collection, all_tables);", + " if (table) {", + " if (label.function_num < 0 || label.function_num >= table->size) {", " FAIL() << \"Bad function call \" << label;", + " } else {", + " return (this->*table->table[label.function_num])(" ++ args ++ ");", " }", - " return (this->*" ++ tableName n2 ++ "[label.function_num])(" ++ args ++ ");", - " }" + " }", + fallback ] args | s == CategoryScope = "params, args" @@ -769,22 +761,42 @@ 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;" +declareTypeArgGetters :: AnyCategory c -> CompiledData [String] +declareTypeArgGetters t = onlyCodes $ map paramGetter (getCategoryName t:refines) where + refines = map (tiName . vrType) $ getCategoryRefines t + paramGetter r = " void Params_" ++ show r ++ "(std::vector>& args) const;" + +defineTypeArgGetters :: AnyCategory c -> CompiledData [String] +defineTypeArgGetters t = onlyCodes $ concat $ map paramGetter (myType:refines) where + params = map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t + myType = (getCategoryName t,map (singleType . JustParamName False . fst) params) + refines = map (\r -> (tiName r,pValues $ tiParams r)) $ map vrType $ getCategoryRefines t + paramGetter (r,ps) = [ + "void " ++ typeName (getCategoryName t) ++ "::Params_" ++ show r ++ "(std::vector>& args) const {", + " args = std::vector>{" ++ intercalate ", " (map expandLocalType ps) ++ "};", + "}" + ] + createTypeArgsForParent :: AnyCategory c -> CompiledData [String] createTypeArgsForParent t - | isInstanceInterface t = onlyCode $ " return " ++ typeBase ++ "::TypeArgsForParent(category, args);" - | otherwise = onlyCodes $ allCats ++ [" return false;"] where - params = map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t - myType = (getCategoryName t,map (singleType . JustParamName False . fst) params) - refines = map (\r -> (tiName r,pValues $ tiParams r)) $ map vrType $ getCategoryRefines t - allCats = concat $ map singleCat (myType:refines) - singleCat (t2,ps) = [ - " if (&category == &" ++ categoryGetter t2 ++ "()) {", - " args = std::vector>{" ++ expanded ++ "};", - " return true;", - " }" - ] - where - expanded = intercalate ", " $ map expandLocalType ps + | isInstanceInterface t = onlyCode $ " return false;" + | otherwise = onlyCodes $ [ + " using CallType = void(" ++ className ++ "::*)(std::vector>&)const;", + " static DispatchSingle all_calls[] = {" + ] ++ map dispatchKeyValue ((getCategoryName t):refines) ++ [ + " DispatchSingle(),", + " };", + " const DispatchSingle* const call = DispatchSelect(&category, all_calls);", + " if (call) {", + " (this->*call->value)(args);", + " return true;", + " }", + " return false;" + ] where + className = typeName $ getCategoryName t + refines = map (tiName . vrType) $ getCategoryRefines t + dispatchKeyValue n = " DispatchSingle(&" ++ categoryGetter n ++ + "(), &" ++ className ++ "::Params_" ++ show n ++ ")," -- Similar to Procedure.expandGeneralInstance but doesn't account for scope. expandLocalType :: GeneralInstance -> String @@ -881,7 +893,7 @@ onlyCodes [ "S " ++ valueCreator (getCategoryName t) ++ "(S<" ++ typeName (getCategoryName t) ++ "> parent, " ++ - "const ParamTuple& params, const ValueTuple& args);" + "const ValueTuple& args);" ] defineInternalValue :: AnyCategory c -> CompiledData [String] @@ -891,8 +903,8 @@ defineInternalValue2 className t = onlyCodes [ "S " ++ valueCreator (getCategoryName t) ++ "(S<" ++ typeName (getCategoryName t) ++ "> parent, " ++ - "const ParamTuple& params, const ValueTuple& args) {", - " return S_get(new " ++ className ++ "(parent, params, args));", + "const ValueTuple& args) {", + " return S_get(new " ++ className ++ "(parent, args));", "}" ] diff --git a/src/CompilerCxx/LanguageModule.hs b/src/CompilerCxx/LanguageModule.hs --- a/src/CompilerCxx/LanguageModule.hs +++ b/src/CompilerCxx/LanguageModule.hs @@ -76,19 +76,18 @@ tmPublic <- foldM includeNewTypes defaultCategories [cs0,cs1] tmPrivate <- foldM includeNewTypes tmPublic [ps0,ps1] tmTesting <- foldM includeNewTypes tmPrivate [ts0,ts1] - let nsPublic = ns0 `Set.union` ns2 - let nsPrivate = ns1 `Set.union` nsPublic - let nsTesting = nsPrivate xxInterfaces <- fmap concat $ collectAllM $ - map (generateNativeInterface False) (onlyNativeInterfaces cs1) ++ - map (generateNativeInterface False) (onlyNativeInterfaces ps1) ++ - map (generateNativeInterface True) (onlyNativeInterfaces ts1) - xxPrivate <- fmap concat $ mapCompilerM (compilePrivate (tmPrivate,nsPrivate) (tmTesting,nsTesting)) xa + map (generateNativeInterface False nsPublic) (onlyNativeInterfaces cs1) ++ + map (generateNativeInterface False nsPrivate) (onlyNativeInterfaces ps1) ++ + map (generateNativeInterface True nsPrivate) (onlyNativeInterfaces ts1) + xxPrivate <- fmap concat $ mapCompilerM (compilePrivate tmPrivate tmTesting) xa xxStreamlined <- fmap concat $ mapCompilerM (streamlined tmTesting) $ nub ss xxVerbose <- fmap concat $ mapCompilerM (verbose tmTesting) $ nub ex let allFiles = xxInterfaces ++ xxPrivate ++ xxStreamlined ++ xxVerbose noDuplicateFiles $ map (\f -> (coFilename f,coNamespace f)) allFiles return allFiles where + nsPublic = ns0 `Set.union` ns2 + nsPrivate = ns1 `Set.union` nsPublic extensions = Set.fromList $ ex ++ ss testingCats = Set.fromList $ map getCategoryName ts1 onlyNativeInterfaces = filter (not . (`Set.member` extensions) . getCategoryName) . filter (not . isValueConcrete) @@ -96,25 +95,25 @@ streamlined tm n = do checkLocal localCats ([] :: [String]) n (_,t) <- getConcreteCategory tm ([],n) - generateStreamlinedExtension (n `Set.member` testingCats) t + generateStreamlinedExtension (n `Set.member` testingCats) nsPrivate t verbose tm n = do checkLocal localCats ([] :: [String]) n (_,t) <- getConcreteCategory tm ([],n) generateVerboseExtension (n `Set.member` testingCats) t - compilePrivate (tmPrivate,nsPrivate) (tmTesting,nsTesting) (PrivateSource ns3 testing cs2 ds) = do - let (tm,ns) = if testing - then (tmTesting,nsTesting) - else (tmPrivate,nsPrivate) + compilePrivate tmPrivate tmTesting (PrivateSource ns3 testing cs2 ds) = do + let tm = if testing + then tmTesting + else tmPrivate let cs = Set.fromList $ map getCategoryName $ if testing then cs2 ++ cs1 ++ ps1 ++ ts1 else cs2 ++ cs1 ++ ps1 tm' <- includeNewTypes tm cs2 - let ctx = FileContext testing tm' (ns3 `Set.insert` ns) em + let ctx = FileContext testing tm' (ns3 `Set.insert` nsPrivate) em checkLocals ds $ Map.keysSet tm' when testing $ checkTests ds (cs1 ++ ps1) let dm = mapDefByName ds checkDefined dm Set.empty $ filter isValueConcrete cs2 - xxInterfaces <- fmap concat $ mapCompilerM (generateNativeInterface testing) (filter (not . isValueConcrete) cs2) + xxInterfaces <- fmap concat $ mapCompilerM (generateNativeInterface testing nsPrivate) (filter (not . isValueConcrete) cs2) xxConcrete <- fmap concat $ mapCompilerM (generateConcrete cs ctx) ds return $ xxInterfaces ++ xxConcrete generateConcrete cs (FileContext testing tm ns em2) d = do diff --git a/src/CompilerCxx/Naming.hs b/src/CompilerCxx/Naming.hs --- a/src/CompilerCxx/Naming.hs +++ b/src/CompilerCxx/Naming.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 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. @@ -33,6 +33,7 @@ functionName, headerFilename, headerStreamlined, + hiddenVariableName, initializerName, intersectGetter, mainFilename, @@ -104,6 +105,9 @@ variableName :: VariableName -> String variableName v = "Var_" ++ show v +hiddenVariableName :: VariableName -> String +hiddenVariableName v = "Internal_" ++ show v + initializerName :: VariableName -> String initializerName v = "Init_" ++ show v @@ -146,10 +150,10 @@ callName :: FunctionName -> String callName f = "Call_" ++ show f -functionDebugName :: ScopedFunction c -> String -functionDebugName f - | sfScope f == CategoryScope = show (sfType f) ++ ":" ++ show (sfName f) - | otherwise = show (sfType f) ++ "." ++ show (sfName f) +functionDebugName :: CategoryName -> ScopedFunction c -> String +functionDebugName t f + | sfScope f == CategoryScope = show t ++ ":" ++ show (sfName f) + | otherwise = show t ++ "." ++ show (sfName f) functionName :: ScopedFunction c -> String functionName f = "Function_" ++ show (sfType f) ++ "_" ++ show (sfName f) diff --git a/src/CompilerCxx/Procedure.hs b/src/CompilerCxx/Procedure.hs --- a/src/CompilerCxx/Procedure.hs +++ b/src/CompilerCxx/Procedure.hs @@ -139,7 +139,7 @@ returnType = "ReturnTuple" setProcedureTrace | any isNoTrace pragmas = return [] - | otherwise = return [startFunctionTracing ff] + | otherwise = return [startFunctionTracing (scName ctx) ff] setCreationTrace | not $ any isTraceCreation pragmas = return [] | s /= ValueScope = @@ -158,7 +158,7 @@ | isUnnamedReturns rs2 = [] | otherwise = map (\(i,(t2,n2)) -> nameReturn i (pvType t2) n2) (zip ([0..] :: [Int]) $ zip (pValues rs1) (pValues $ nrNames rs2)) nameReturn i t2 n2 - | isPrimType t2 = variableProxyType t2 ++ " " ++ variableName (ovName n2) ++ ";" + | isPrimitiveType t2 = variableProxyType t2 ++ " " ++ variableName (ovName n2) ++ ";" | otherwise = variableProxyType t2 ++ " " ++ variableName (ovName n2) ++ " = " ++ writeStoredVariable t2 (UnwrappedSingle $ "returns.At(" ++ show i ++ ")") ++ ";" @@ -298,7 +298,7 @@ self <- autoSelfType t1' <- lift $ replaceSelfValueType self t1 -- TODO: Call csAddRequired for t1'. (Maybe needs a helper function.) - lift $ collectAllM_ [validateGeneralInstance r fa (vtType t1'), + lift $ collectAllM_ [validateGeneralInstance r (Map.keysSet fa) (vtType t1'), checkValueAssignment r fa t2 t1'] csAddVariable (UsedVariable c2 n) (VariableValue c2 LocalScope t1' VariableDefault) csWrite [variableStoredType t1' ++ " " ++ variableName n ++ ";"] @@ -369,7 +369,7 @@ CompilerContext c m [String] a) => VoidExpression c -> CompilerState a m () compileVoidExpression (Conditional ie) = compileIfElifElse ie -compileVoidExpression (Loop l) = compileWhileLoop l +compileVoidExpression (Loop l) = compileIteratedLoop l compileVoidExpression (WithScope s) = compileScopedBlock s compileVoidExpression (LineComment s) = csWrite $ map ("// " ++) $ lines s compileVoidExpression (Unconditional p) = do @@ -407,10 +407,9 @@ return $ ctx:cs compileIfElifElse _ = undefined -compileWhileLoop :: (Ord c, Show c, CollectErrorsM m, - CompilerContext c m [String] a) => - WhileLoop c -> CompilerState a m () -compileWhileLoop (WhileLoop c e p u) = do +compileIteratedLoop :: (Ord c, Show c, CollectErrorsM m, CompilerContext c m [String] a) => + IteratedLoop c -> CompilerState a m () +compileIteratedLoop (WhileLoop c e p u) = do ctx0 <- getCleanContext (e',ctx1) <- compileCondition ctx0 c e csInheritReturns [ctx1] @@ -429,6 +428,38 @@ getAndIndentOutput ctx >>= csWrite csWrite $ ["{"] ++ u' ++ ["}"] csWrite ["}"] +compileIteratedLoop (TraverseLoop c1 e c2 a (Procedure c3 ss)) = "In compilation of traverse at " ++ formatFullContext c1 ??> do + (Positional ts,e') <- compileExpression e + checkContainer ts + r <- csResolver + fa <- csAllFilters + let [t] = ts + let autoParam = ParamName "#auto" + let autoType = singleType $ JustParamName False autoParam + (Positional [t2]) <- lift $ guessParams r fa (Positional [orderOptionalValue autoType]) + (Positional [autoParam]) + (Positional [InferredInstance c1]) + (Positional [t]) + let currVar = hiddenVariableName $ VariableName "traverse" + let currType = orderOptionalValue $ fixTypeParams t2 + let currExpr = BuiltinCall [] $ FunctionCall [] BuiltinRequire (Positional []) (Positional [RawExpression (Positional [currType]) (UnwrappedSingle currVar)]) + let currPresent = BuiltinCall [] $ FunctionCall [] BuiltinPresent (Positional []) (Positional [RawExpression (Positional [currType]) (UnwrappedSingle currVar)]) + let callNext = Expression c1 currExpr [ValueCall c1 $ FunctionCall c1 (FunctionName "next") (Positional []) (Positional [])] + let callGet = Expression c2 currExpr [ValueCall c2 $ FunctionCall c2 (FunctionName "get") (Positional []) (Positional [])] + (Positional [typeGet],exprNext) <- compileExpression callNext + when (typeGet /= currType) $ compilerErrorM $ "Unexpected return type from next(): " ++ show typeGet ++ " (expected) " ++ show currType ++ " (actual)" + let assnGet = Assignment c2 (Positional [a]) callGet + csAddRequired $ categoriesFromTypes $ vtType currType + compileStatement $ NoValueExpression [] $ WithScope $ ScopedBlock [] + (Procedure [] [RawCodeLine $ variableStoredType currType ++ " " ++ currVar ++ " = " ++ writeStoredVariable currType e' ++ ";"]) Nothing [] + (NoValueExpression [] $ Loop $ WhileLoop [] (Expression [] currPresent []) + (Procedure c3 (assnGet:ss)) + (Just $ Procedure [] [RawCodeLine $ currVar ++ " = " ++ writeStoredVariable currType exprNext ++ ";"])) + where + checkContainer [_] = return () + checkContainer ts = + compilerErrorM $ "Expected exactly one Order value but got " ++ + intercalate ", " (map show ts) compileScopedBlock :: (Ord c, Show c, CollectErrorsM m, CompilerContext c m [String] a) => @@ -473,7 +504,7 @@ t' <- replaceSelfValueType self t return (c,t',n) createVariable r fa (c,t,n) = do - lift $ validateGeneralInstance r fa (vtType t) - Expression c -> CompilerState a m (ExpressionType,ExprValue) + Expression c -> CompilerState a m (ExpressionType,ExpressionValue) compileExpression = compile where compile (Literal (StringLiteral _ l)) = do csAddRequired (Set.fromList [BuiltinString]) @@ -534,7 +565,7 @@ csAddRequired (Set.fromList [BuiltinBool]) return (Positional [boolRequiredValue],UnboxedPrimitive PrimBool "false") compile (Literal (EmptyLiteral _)) = do - return (Positional [emptyValue],UnwrappedSingle "Var_empty") + return (Positional [emptyType],UnwrappedSingle "Var_empty") compile (Expression _ s os) = do foldl transform (compileExpressionStart s) os compile (UnaryExpression c (FunctionOperator _ (FunctionSpec _ (CategoryFunction c2 cn) fn ps)) e) = @@ -577,7 +608,7 @@ UnboxedPrimitive PrimInt $ "~" ++ useAsUnboxed PrimInt e2) | otherwise = compilerErrorM $ "Cannot use " ++ show t ++ " with unary ~ operator" ++ formatFullContextBrace c - compile (InitializeValue c t ps es) = do + compile (InitializeValue c t es) = do scope <- csCurrentScope t' <- case scope of CategoryScope -> case t of @@ -590,15 +621,14 @@ Nothing -> return self es' <- sequence $ map compileExpression $ pValues es (ts,es'') <- lift $ getValues es' - csCheckValueInit c t' (Positional ts) ps + csCheckValueInit c t' (Positional ts) params <- expandParams $ tiParams t' - params2 <- expandParams2 $ ps sameType <- csSameType t' s <- csCurrentScope let typeInstance = getType t' sameType s params -- TODO: This is unsafe if used in a type or category constructor. return (Positional [ValueType RequiredValue $ singleType $ JustTypeInstance t'], - UnwrappedSingle $ valueCreator (tiName t') ++ "(" ++ typeInstance ++ ", " ++ params2 ++ ", " ++ es'' ++ ")") + UnwrappedSingle $ valueCreator (tiName t') ++ "(" ++ typeInstance ++ ", " ++ es'' ++ ")") where getType _ True ValueScope _ = "parent" getType t2 _ _ params = typeCreator (tiName t2) ++ "(" ++ params ++ ")" @@ -627,6 +657,7 @@ then isolateExpression e2 -- Ignore named-return assignments. else compileExpression e2 bindInfix c e1' o e2' + compile (RawExpression ts e) = return (ts,e) isolateExpression e = do ctx <- getCleanContext (e',ctx') <- lift $ runStateT (compileExpression e) ctx @@ -719,7 +750,7 @@ compileExpressionStart :: (Ord c, Show c, CollectErrorsM m, CompilerContext c m [String] a) => - ExpressionStart c -> CompilerState a m (ExpressionType,ExprValue) + ExpressionStart c -> CompilerState a m (ExpressionType,ExpressionValue) compileExpressionStart (NamedVariable (OutputValue c n)) = do let var = UsedVariable c n (VariableValue _ s t _) <- csGetVariable var @@ -745,7 +776,7 @@ t' <- lift $ replaceSelfInstance self (singleType t) r <- csResolver fa <- csAllFilters - lift $ validateGeneralInstance r fa t' t2 then just return e without a Reduce call. @@ -844,7 +875,7 @@ [t] <- lift $ mapCompilerM (replaceSelfInstance self) ps' r <- csResolver fa <- csAllFilters - lift $ validateGeneralInstance r fa t + lift $ validateGeneralInstance r (Map.keysSet fa) t t' <- expandGeneralInstance t csAddRequired $ Set.unions $ map categoriesFromTypes [t] return $ (Positional [formattedRequiredValue], @@ -873,7 +904,7 @@ compileFunctionCall :: (Ord c, Show c, CollectErrorsM m, CompilerContext c m [String] a) => Maybe String -> ScopedFunction c -> FunctionCall c -> - CompilerState a m (ExpressionType,ExprValue) + CompilerState a m (ExpressionType,ExpressionValue) compileFunctionCall e f (FunctionCall c _ ps es) = message ??> do r <- csResolver fa <- csAllFilters @@ -952,6 +983,23 @@ toInstance p1 (AssignedInstance _ t) = return (p1,t) toInstance p1 (InferredInstance _) = return (p1,singleType $ JustInferredType p1) +guessParams :: (Ord c, Show c, CollectErrorsM m, TypeResolver r) => + r -> ParamFilters -> Positional ValueType -> Positional ParamName -> + Positional (InstanceOrInferred c) -> Positional ValueType -> m (Positional GeneralInstance) +guessParams r fa args params ps ts = do + args' <- processPairs (\t1 t2 -> return $ PatternMatch Covariant t1 t2) ts args + pa <- fmap Map.fromList $ processPairs toInstance params ps + gs <- inferParamTypes r fa pa args' + gs' <- mergeInferredTypes r fa (Map.fromList $ zip (pValues params) (repeat [])) pa gs + let pa3 = guessesAsParams gs' `Map.union` pa + fmap Positional $ mapCompilerM (subPosition pa3) (pValues params) where + subPosition pa2 p = + case p `Map.lookup` pa2 of + Just t -> return t + Nothing -> compilerErrorM $ "Something went wrong inferring " ++ show p + toInstance p1 (AssignedInstance _ t) = return (p1,t) + toInstance p1 (InferredInstance _) = return (p1,singleType $ JustInferredType p1) + compileMainProcedure :: (Ord c, Show c, CollectErrorsM m) => CategoryMap c -> ExprMap c -> Expression c -> m (CompiledData [String]) compileMainProcedure tm em e = do @@ -1083,7 +1131,7 @@ where autoPositionalCleanup :: (CollectErrorsM m, CompilerContext c m [String] a) => - [c] -> ExprValue -> CompilerState a m () + [c] -> ExpressionValue -> CompilerState a m () autoPositionalCleanup c e = do named <- csIsNamedReturns (CleanupBlock ss _ _ req) <- csGetCleanup JumpReturn diff --git a/src/Module/CompileMetadata.hs b/src/Module/CompileMetadata.hs --- a/src/Module/CompileMetadata.hs +++ b/src/Module/CompileMetadata.hs @@ -80,6 +80,10 @@ } deriving (Eq,Ord,Show) +getIdentifierCategory :: CategoryIdentifier -> CategoryName +getIdentifierCategory (CategoryIdentifier _ n _) = n +getIdentifierCategory (UnresolvedCategory n) = n + mergeObjectFiles :: ObjectFile -> ObjectFile -> ObjectFile mergeObjectFiles (CategoryObjectFile c rs1 fs1) (CategoryObjectFile _ rs2 fs2) = CategoryObjectFile c (nub $ rs1 ++ rs2) (nub $ fs1 ++ fs2) diff --git a/src/Module/ParseMetadata.hs b/src/Module/ParseMetadata.hs --- a/src/Module/ParseMetadata.hs +++ b/src/Module/ParseMetadata.hs @@ -372,7 +372,6 @@ indent "]", "}" ] - writeConfig CompileUnspecified = writeConfig (CompileIncremental []) writeConfig _ = compilerErrorM "Invalid compile mode" parseExprMacro :: TextParser (MacroName,Expression SourceContext) diff --git a/src/Parser/Common.hs b/src/Parser/Common.hs --- a/src/Parser/Common.hs +++ b/src/Parser/Common.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 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. @@ -62,6 +62,7 @@ kwSelf, kwStrong, kwTestcase, + kwTraverse, kwTrue, kwType, kwTypename, @@ -263,6 +264,9 @@ kwTestcase :: TextParser () kwTestcase = keyword "testcase" +kwTraverse :: TextParser () +kwTraverse = keyword "traverse" + kwTrue :: TextParser () kwTrue = keyword "true" @@ -337,6 +341,7 @@ kwScoped, kwStrong, kwTestcase, + kwTraverse, kwTrue, kwType, kwTypename, diff --git a/src/Parser/DefinedCategory.hs b/src/Parser/DefinedCategory.hs --- a/src/Parser/DefinedCategory.hs +++ b/src/Parser/DefinedCategory.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 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. @@ -25,15 +25,15 @@ import Base.CompilerError import Parser.Common +import Parser.Pragma (autoPragma) import Parser.Procedure () -import Parser.TextParser +import Parser.TextParser hiding (hidden) import Parser.TypeCategory import Parser.TypeInstance () import Types.DefinedCategory import Types.Procedure import Types.TypeCategory import Types.TypeInstance -import Types.Variance instance ParseFromSource (DefinedCategory SourceContext) where @@ -42,30 +42,23 @@ kwDefine n <- sourceParser sepAfter (string_ "{") + pragmas <- sepBy singlePragma optionalSpace (ds,rs) <- parseRefinesDefines - (pi,fi) <- parseInternalParams <|> return ([],[]) (ms,ps,fs) <- parseMemberProcedureFunction n sepAfter (string_ "}") - return $ DefinedCategory [c] n pi ds rs fi ms ps fs + return $ DefinedCategory [c] n pragmas ds rs ms ps fs where parseRefinesDefines = fmap merge2 $ sepBy refineOrDefine optionalSpace + singlePragma = readOnly <|> hidden + readOnly = autoPragma "ReadOnly" $ Right parseAt where + parseAt c = do + vs <- labeled "variable names" $ sepBy sourceParser (sepAfter $ string ",") + return $ MembersReadOnly [c] vs + hidden = autoPragma "Hidden" $ Right parseAt where + parseAt c = do + vs <- labeled "variable names" $ sepBy sourceParser (sepAfter $ string ",") + return $ MembersHidden [c] vs refineOrDefine = labeled "refine or define" $ put12 singleRefine <|> put22 singleDefine - parseInternalParams = labeled "internal params" $ do - kwTypes - pi <- between (sepAfter $ string_ "<") - (sepAfter $ string_ ">") - (sepBy singleParam (sepAfter $ string_ ",")) - fi <- parseInternalFilters - return (pi,fi) - parseInternalFilters = do - try $ sepAfter (string_ "{") - fi <- parseFilters - sepAfter (string_ "}") - return fi - singleParam = labeled "param declaration" $ do - c <- getSourceContext - n <- sourceParser - return $ ValueParam [c] n Invariant instance ParseFromSource (DefinedMember SourceContext) where sourceParser = labeled "defined member" $ do diff --git a/src/Parser/Procedure.hs b/src/Parser/Procedure.hs --- a/src/Parser/Procedure.hs +++ b/src/Parser/Procedure.hs @@ -225,18 +225,30 @@ p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser return $ ElseStatement [c] p -instance ParseFromSource (WhileLoop SourceContext) where - sourceParser = labeled "while" $ do - c <- getSourceContext - kwWhile - i <- between (sepAfter $ string_ "(") (sepAfter $ string_ ")") sourceParser - p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser - u <- fmap Just parseUpdate <|> return Nothing - return $ WhileLoop [c] i p u - where - parseUpdate = do - kwUpdate - between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser +instance ParseFromSource (IteratedLoop SourceContext) where + sourceParser = while <|> trav where + while = labeled "while" $ do + c <- getSourceContext + kwWhile + i <- between (sepAfter $ string_ "(") (sepAfter $ string_ ")") sourceParser + p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser + u <- fmap Just parseUpdate <|> return Nothing + return $ WhileLoop [c] i p u + where + parseUpdate = do + kwUpdate + between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser + trav = labeled "traverse" $ do + c1 <- getSourceContext + kwTraverse + sepAfter_ $ string "(" + e <- sourceParser + sepAfter_ $ string "->" + c2 <- getSourceContext + a <- sourceParser + sepAfter_ $ string ")" + p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser + return $ TraverseLoop [c1] e [c2] a p instance ParseFromSource (ScopedBlock SourceContext) where sourceParser = scoped <|> justCleanup where @@ -417,19 +429,9 @@ t2 <- (paramSelf >> return Nothing) <|> fmap Just sourceParser sepAfter (labeled "@value initializer" $ string_ "{") return t2 - withParams c t <|> withoutParams c t - withParams c t = do - kwTypes - ps <- between (sepAfter $ string_ "<") - (sepAfter $ string_ ">") - (sepBy sourceParser (sepAfter $ string_ ",")) - as <- (sepAfter (string_ ",") >> sepBy sourceParser (sepAfter $ string_ ",")) <|> return [] - sepAfter (string_ "}") - return $ InitializeValue [c] t (Positional ps) (Positional as) - withoutParams c t = do as <- sepBy sourceParser (sepAfter $ string_ ",") sepAfter (string_ "}") - return $ InitializeValue [c] t (Positional []) (Positional as) + return $ InitializeValue [c] t (Positional as) instance ParseFromSource (FunctionQualifier SourceContext) where -- TODO: This is probably better done iteratively. diff --git a/src/Parser/TypeCategory.hs b/src/Parser/TypeCategory.hs --- a/src/Parser/TypeCategory.hs +++ b/src/Parser/TypeCategory.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019 Kevin P. Barry +Copyright 2019,2021 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. @@ -46,20 +46,19 @@ n <- sourceParser ps <- parseCategoryParams open - (rs,vs) <- parseRefinesFilters + rs <- parseCategoryRefines fs <- flip sepBy optionalSpace $ parseScopedFunction (return ValueScope) (return n) close - return $ ValueInterface [c] NoNamespace n ps rs vs fs + return $ ValueInterface [c] NoNamespace n ps rs fs parseInstance = labeled "type interface" $ do c <- getSourceContext try $ kwType >> kwInterface n <- sourceParser ps <- parseCategoryParams open - vs <- parseFilters fs <- flip sepBy optionalSpace $ parseScopedFunction (return TypeScope) (return n) close - return $ InstanceInterface [c] NoNamespace n ps vs fs + return $ InstanceInterface [c] NoNamespace n ps fs parseConcrete = labeled "concrete type" $ do c <- getSourceContext kwConcrete @@ -139,11 +138,6 @@ parseFilters :: TextParser [ParamFilter SourceContext] parseFilters = sepBy singleFilter optionalSpace - -parseRefinesFilters :: TextParser ([ValueRefine SourceContext],[ParamFilter SourceContext]) -parseRefinesFilters = parsed >>= return . merge2 where - parsed = sepBy anyType optionalSpace - anyType = labeled "refine or param filter" $ put12 singleRefine <|> put22 singleFilter parseRefinesDefinesFilters :: TextParser ([ValueRefine SourceContext],[ValueDefine SourceContext],[ParamFilter SourceContext]) diff --git a/src/Test/Common.hs b/src/Test/Common.hs --- a/src/Test/Common.hs +++ b/src/Test/Common.hs @@ -31,11 +31,12 @@ forceParse, loadFile, parseFilterMap, - parseTheTest, + parseTestWithFilters, readMulti, readSingle, readSingleWith, runAllTests, + showFilters, showParams, ) where @@ -93,27 +94,35 @@ fs2 <- mapCompilerM (readSingle "(string)") fs return (ParamName n,fs2) -parseTheTest :: ParseFromSource a => [(String,[String])] -> [String] -> TrackedErrors ([a],ParamFilters) -parseTheTest pa xs = do +parseTestWithFilters :: ParseFromSource a => [(String,[String])] -> [String] -> TrackedErrors ([a],ParamFilters) +parseTestWithFilters pa xs = do ts <- mapCompilerM (readSingle "(string)") xs pa2 <- parseFilterMap pa return (ts,pa2) -showParams :: [(String,[String])] -> String -showParams pa = "[" ++ intercalate "," (concat $ map expand pa) ++ "]" where +parseTestWithParams :: ParseFromSource a => [String] -> [String] -> TrackedErrors ([a],Set.Set ParamName) +parseTestWithParams ps xs = do + ts <- mapCompilerM (readSingle "(string)") xs + return (ts,Set.fromList $ map ParamName ps) + +showFilters :: [(String,[String])] -> String +showFilters pa = "[" ++ intercalate "," (concat $ map expand pa) ++ "]" where expand (n,ps) = map (\p -> n ++ " " ++ p) ps -checkTypeSuccess :: TypeResolver r => r -> [(String,[String])] -> String -> TrackedErrors () +showParams :: [String] -> String +showParams ps = "[" ++ intercalate "," ps ++ "]" + +checkTypeSuccess :: TypeResolver r => r -> [String] -> String -> TrackedErrors () checkTypeSuccess r pa x = do - ([t],pa2) <- parseTheTest pa [x] + ([t],pa2) <- parseTestWithParams pa [x] check $ validateGeneralInstance r pa2 t where prefix = x ++ " " ++ showParams pa check x2 = x2 r -> [(String,[String])] -> String -> TrackedErrors () +checkTypeFail :: TypeResolver r => r -> [String] -> String -> TrackedErrors () checkTypeFail r pa x = do - ([t],pa2) <- parseTheTest pa [x] + ([t],pa2) <- parseTestWithParams pa [x] check $ validateGeneralInstance r pa2 t where prefix = x ++ " " ++ showParams pa @@ -122,17 +131,17 @@ | isCompilerError c = return () | otherwise = compilerErrorM $ prefix ++ ": Expected failure\n" -checkDefinesSuccess :: TypeResolver r => r -> [(String,[String])] -> String -> TrackedErrors () +checkDefinesSuccess :: TypeResolver r => r -> [String] -> String -> TrackedErrors () checkDefinesSuccess r pa x = do - ([t],pa2) <- parseTheTest pa [x] + ([t],pa2) <- parseTestWithParams pa [x] check $ validateDefinesInstance r pa2 t where prefix = x ++ " " ++ showParams pa check x2 = x2 r -> [(String,[String])] -> String -> TrackedErrors () +checkDefinesFail :: TypeResolver r => r -> [String] -> String -> TrackedErrors () checkDefinesFail r pa x = do - ([t],pa2) <- parseTheTest pa [x] + ([t],pa2) <- parseTestWithParams pa [x] check $ validateDefinesInstance r pa2 t where prefix = x ++ " " ++ showParams pa diff --git a/src/Test/DefinedCategory.hs b/src/Test/DefinedCategory.hs --- a/src/Test/DefinedCategory.hs +++ b/src/Test/DefinedCategory.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019 Kevin P. Barry +Copyright 2019,2021 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. @@ -31,9 +31,7 @@ tests :: [IO (TrackedErrors ())] tests = [ checkParseSuccess ("testfiles" "definitions.0rx"), - checkParseSuccess ("testfiles" "internal_inheritance.0rx"), - checkParseSuccess ("testfiles" "internal_params.0rx"), - checkParseSuccess ("testfiles" "internal_filters.0rx") + checkParseSuccess ("testfiles" "internal_inheritance.0rx") ] checkParseSuccess :: String -> IO (TrackedErrors ()) @@ -55,4 +53,4 @@ check c | isCompilerError c = return () | otherwise = compilerErrorM $ "Parse " ++ f ++ ": Expected failure but got\n" ++ - show (getCompilerSuccess c) ++ "\n" + show (getCompilerSuccess c) ++ "\n" diff --git a/src/Test/ParseMetadata.hs b/src/Test/ParseMetadata.hs --- a/src/Test/ParseMetadata.hs +++ b/src/Test/ParseMetadata.hs @@ -353,7 +353,7 @@ ] }, - checkWriteFail "compile mode" $ ExecuteTests { etInclude = [] }, + checkWriteFail "compile mode" $ ExecuteTests { etInclude = [], etCallLog = Nothing }, checkWriteFail "compile mode" $ CompileRecompile, checkWriteFail "compile mode" $ CompileRecompileRecursive, checkWriteFail "compile mode" $ CreateTemplates, diff --git a/src/Test/TypeCategory.hs b/src/Test/TypeCategory.hs --- a/src/Test/TypeCategory.hs +++ b/src/Test/TypeCategory.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 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. @@ -65,13 +65,13 @@ checkShortParseSuccess "@type interface Type {}", checkShortParseFail "@type interface Type { refines T }", checkShortParseFail "@type interface Type { defines T }", - checkShortParseSuccess "@type interface Type<#x> { #x allows T }", + checkShortParseFail "@type interface Type<#x> { #x allows T }", checkShortParseSuccess "@value interface Type<#x> {}", checkShortParseSuccess "@value interface Type {}", checkShortParseSuccess "@value interface Type { refines T }", checkShortParseFail "@value interface Type { defines T }", - checkShortParseSuccess "@value interface Type<#x> { #x allows T }", + checkShortParseFail "@value interface Type<#x> { #x allows T }", checkShortParseSuccess "@value interface Type { call () -> (#self) }", checkShortParseFail "@value interface Type<#self> {}", @@ -98,23 +98,23 @@ checkOperationSuccess ("testfiles" "concrete_refines_value.0rx") (checkConnectedTypes $ Map.fromList [ - (CategoryName "Parent2",InstanceInterface [] NoNamespace (CategoryName "Parent2") [] [] []) + (CategoryName "Parent2",InstanceInterface [] NoNamespace (CategoryName "Parent2") [] []) ]), checkOperationFail ("testfiles" "concrete_refines_value.0rx") (checkConnectedTypes $ Map.fromList [ - (CategoryName "Parent",InstanceInterface [] NoNamespace (CategoryName "Parent") [] [] []) + (CategoryName "Parent",InstanceInterface [] NoNamespace (CategoryName "Parent") [] []) ]), checkOperationSuccess ("testfiles" "partial.0rx") (checkConnectedTypes $ Map.fromList [ - (CategoryName "Parent",ValueInterface [] NoNamespace (CategoryName "Parent") [] [] [] []) + (CategoryName "Parent",ValueInterface [] NoNamespace (CategoryName "Parent") [] [] []) ]), checkOperationFail ("testfiles" "partial.0rx") (checkConnectedTypes $ Map.fromList [ - (CategoryName "Parent",InstanceInterface [] NoNamespace (CategoryName "Parent") [] [] []) + (CategoryName "Parent",InstanceInterface [] NoNamespace (CategoryName "Parent") [] []) ]), checkOperationFail ("testfiles" "partial.0rx") @@ -165,7 +165,7 @@ ("testfiles" "flatten.0rx") (\ts -> do existing <- return $ Map.fromList [ - (CategoryName "Parent2",InstanceInterface [] NoNamespace (CategoryName "Parent2") [] [] []) + (CategoryName "Parent2",InstanceInterface [] NoNamespace (CategoryName "Parent2") [] []) ] ts2 <- topoSortCategories existing ts flattenAllConnections existing ts2), @@ -173,7 +173,7 @@ ("testfiles" "flatten.0rx") (\ts -> do existing <- return $ Map.fromList [ - (CategoryName "Parent",InstanceInterface [] NoNamespace (CategoryName "Parent") [] [] []) + (CategoryName "Parent",InstanceInterface [] NoNamespace (CategoryName "Parent") [] []) ] topoSortCategories existing ts), @@ -184,11 +184,11 @@ (CategoryName "Parent", ValueInterface [] NoNamespace (CategoryName "Parent") [] [ValueRefine [] $ TypeInstance (CategoryName "Object1") (Positional []), - ValueRefine [] $ TypeInstance (CategoryName "Object2") (Positional [])] [] []), + ValueRefine [] $ TypeInstance (CategoryName "Object2") (Positional [])] []), -- NOTE: Object1 deliberately excluded here so that we catch -- unnecessary recursion in existing categories. (CategoryName "Object2", - ValueInterface [] NoNamespace (CategoryName "Object2") [] [] [] []) + ValueInterface [] NoNamespace (CategoryName "Object2") [] [] []) ] ts2 <- topoSortCategories existing ts ts3 <- flattenAllConnections existing ts2 @@ -214,12 +214,12 @@ checkOperationSuccess ("testfiles" "concrete_refines_value.0rx") (checkParamVariances $ Map.fromList [ - (CategoryName "Parent2",InstanceInterface [] NoNamespace (CategoryName "Parent2") [] [] []) + (CategoryName "Parent2",InstanceInterface [] NoNamespace (CategoryName "Parent2") [] []) ]), checkOperationFail ("testfiles" "concrete_refines_value.0rx") (checkParamVariances $ Map.fromList [ - (CategoryName "Parent",InstanceInterface [] NoNamespace (CategoryName "Parent") [] [] []) + (CategoryName "Parent",InstanceInterface [] NoNamespace (CategoryName "Parent") [] []) ]), checkOperationSuccess @@ -228,7 +228,7 @@ (CategoryName "Parent", ValueInterface [] NoNamespace (CategoryName "Parent") [ValueParam [] (ParamName "#w") Contravariant, - ValueParam [] (ParamName "#z") Covariant] [] [] []) + ValueParam [] (ParamName "#z") Covariant] [] []) ]), checkOperationFail ("testfiles" "partial_params.0rx") @@ -236,7 +236,7 @@ (CategoryName "Parent", ValueInterface [] NoNamespace (CategoryName "Parent") [ValueParam [] (ParamName "#w") Invariant, - ValueParam [] (ParamName "#z") Covariant] [] [] []) + ValueParam [] (ParamName "#z") Covariant] [] []) ]), checkOperationFail ("testfiles" "partial_params.0rx") @@ -244,7 +244,7 @@ (CategoryName "Parent", ValueInterface [] NoNamespace (CategoryName "Parent") [ValueParam [] (ParamName "#w") Contravariant, - ValueParam [] (ParamName "#z") Invariant] [] [] []) + ValueParam [] (ParamName "#z") Invariant] [] []) ]), checkOperationSuccess @@ -358,56 +358,6 @@ [] ]), - checkOperationSuccess - ("testfiles" "value_interface.0rx") - (\ts -> do - rs <- getTypeFilters ts "Type<#a,#b,#c,#d,#e,#f>" - checkPaired containsExactly rs [ - ["allows Parent"], - ["requires Type2<#a>"], - ["defines Equals<#c>"], - [], - [], - [] - ]), - checkOperationSuccess - ("testfiles" "value_interface.0rx") - (\ts -> do - rs <- getTypeFilters ts "Type,#b,Type3<#x>,#d,#e,#f>" - checkPaired containsExactly rs [ - ["allows Parent"], - ["requires Type2>"], - ["defines Equals>"], - [], - [], - [] - ]), - - checkOperationSuccess - ("testfiles" "type_interface.0rx") - (\ts -> do - rs <- getTypeDefinesFilters ts "Type<#a,#b,#c,#d,#e,#f>" - checkPaired containsExactly rs [ - ["allows Parent"], - ["requires Type2<#a>"], - ["defines Equals<#c>"], - [], - [], - [] - ]), - checkOperationSuccess - ("testfiles" "type_interface.0rx") - (\ts -> do - rs <- getTypeDefinesFilters ts "Type,#b,Type3<#x>,#d,#e,#f>" - checkPaired containsExactly rs [ - ["allows Parent"], - ["requires Type2>"], - ["defines Equals>"], - [], - [], - [] - ]), - -- TODO: Clean these tests up. checkOperationSuccess ("testfiles" "flatten.0rx") @@ -481,7 +431,7 @@ ta <- flattenAllConnections Map.empty ts2 >>= declareAllTypes Map.empty let r = CategoryResolver ta checkTypeSuccess r [] "Value0"), - checkOperationFail + checkOperationSuccess ("testfiles" "filters.0rx") (\ts -> do ts2 <- topoSortCategories Map.empty ts @@ -495,14 +445,14 @@ ta <- flattenAllConnections Map.empty ts2 >>= declareAllTypes Map.empty let r = CategoryResolver ta checkTypeSuccess r [] "Value0"), - checkOperationFail + checkOperationSuccess ("testfiles" "filters.0rx") (\ts -> do ts2 <- topoSortCategories Map.empty ts ta <- flattenAllConnections Map.empty ts2 >>= declareAllTypes Map.empty let r = CategoryResolver ta checkTypeSuccess r - [("#x",[]),("#y",[])] + ["#x","#y"] "Value0<#x,#y>"), checkOperationSuccess ("testfiles" "filters.0rx") @@ -511,8 +461,7 @@ ta <- flattenAllConnections Map.empty ts2 >>= declareAllTypes Map.empty let r = CategoryResolver ta checkTypeSuccess r - [("#x",["allows #y","requires Function<#x,#y>"]), - ("#y",["requires #x","defines Equals<#y>"])] + ["#x","#y"] "Value0<#x,#y>"), checkOperationSuccess ("testfiles" "filters.0rx") @@ -521,74 +470,19 @@ ta <- flattenAllConnections Map.empty ts2 >>= declareAllTypes Map.empty let r = CategoryResolver ta checkTypeSuccess r - [("#x",["allows Value2","requires Function<#x,Value2>"])] + ["#x","#y"] "Value0<#x,Value2>"), - checkOperationFail + checkOperationSuccess ("testfiles" "filters.0rx") (\ts -> do ts2 <- topoSortCategories Map.empty ts ta <- flattenAllConnections Map.empty ts2 >>= declareAllTypes Map.empty let r = CategoryResolver ta checkTypeSuccess r - [("#x",["allows Value2","requires Function<#x,Value2>"]), - ("#y",["requires #x","defines Equals<#y>"])] + ["#x","#y"] "Value0<#x,#y>"), checkOperationSuccess - ("testfiles" "concrete_instances.0rx") - (\ts -> do - ts2 <- topoSortCategories defaultCategories ts - ts3 <- flattenAllConnections defaultCategories ts2 - checkCategoryInstances defaultCategories ts3), - checkOperationFail - ("testfiles" "concrete_missing_define.0rx") - (\ts -> do - ts2 <- topoSortCategories defaultCategories ts - ts3 <- flattenAllConnections defaultCategories ts2 - checkCategoryInstances defaultCategories ts3), - checkOperationFail - ("testfiles" "concrete_missing_refine.0rx") - (\ts -> do - ts2 <- topoSortCategories defaultCategories ts - ts3 <- flattenAllConnections defaultCategories ts2 - checkCategoryInstances defaultCategories ts3), - checkOperationSuccess - ("testfiles" "value_instances.0rx") - (\ts -> do - ts2 <- topoSortCategories defaultCategories ts - ts3 <- flattenAllConnections defaultCategories ts2 - checkCategoryInstances defaultCategories ts3), - checkOperationFail - ("testfiles" "value_missing_define.0rx") - (\ts -> do - ts2 <- topoSortCategories defaultCategories ts - ts3 <- flattenAllConnections defaultCategories ts2 - checkCategoryInstances defaultCategories ts3), - checkOperationFail - ("testfiles" "value_missing_refine.0rx") - (\ts -> do - ts2 <- topoSortCategories defaultCategories ts - ts3 <- flattenAllConnections defaultCategories ts2 - checkCategoryInstances defaultCategories ts3), - checkOperationSuccess - ("testfiles" "type_instances.0rx") - (\ts -> do - ts2 <- topoSortCategories defaultCategories ts - ts3 <- flattenAllConnections defaultCategories ts2 - checkCategoryInstances defaultCategories ts3), - checkOperationFail - ("testfiles" "type_missing_define.0rx") - (\ts -> do - ts2 <- topoSortCategories defaultCategories ts - ts3 <- flattenAllConnections defaultCategories ts2 - checkCategoryInstances defaultCategories ts3), - checkOperationFail - ("testfiles" "type_missing_refine.0rx") - (\ts -> do - ts2 <- topoSortCategories defaultCategories ts - ts3 <- flattenAllConnections defaultCategories ts2 - checkCategoryInstances defaultCategories ts3), - checkOperationSuccess ("testfiles" "requires_concrete.0rx") (\ts -> do ts2 <- topoSortCategories defaultCategories ts @@ -641,7 +535,7 @@ ("testfiles" "flatten.0rx") (\ts -> do let tm0 = Map.fromList [ - (CategoryName "Parent2",InstanceInterface [] NoNamespace (CategoryName "Parent2") [] [] []) + (CategoryName "Parent2",InstanceInterface [] NoNamespace (CategoryName "Parent2") [] []) ] tm <- includeNewTypes tm0 ts rs <- getRefines tm "Child" @@ -662,30 +556,15 @@ ("testfiles" "function_bad_filter_param.0rx") (\ts -> checkCategoryInstances defaultCategories ts), checkOperationFail - ("testfiles" "function_bad_allows_type.0rx") - (\ts -> checkCategoryInstances defaultCategories ts), - checkOperationFail ("testfiles" "function_bad_allows_variance.0rx") (\ts -> checkCategoryInstances defaultCategories ts), checkOperationFail - ("testfiles" "function_bad_requires_type.0rx") - (\ts -> checkCategoryInstances defaultCategories ts), - checkOperationFail ("testfiles" "function_bad_requires_variance.0rx") (\ts -> checkCategoryInstances defaultCategories ts), checkOperationFail - ("testfiles" "function_bad_defines_type.0rx") - (\ts -> checkCategoryInstances defaultCategories ts), - checkOperationFail ("testfiles" "function_bad_defines_variance.0rx") (\ts -> checkCategoryInstances defaultCategories ts), checkOperationFail - ("testfiles" "function_bad_arg.0rx") - (\ts -> checkCategoryInstances defaultCategories ts), - checkOperationFail - ("testfiles" "function_bad_return.0rx") - (\ts -> checkCategoryInstances defaultCategories ts), - checkOperationFail ("testfiles" "weak_arg.0rx") (\ts -> checkCategoryInstances defaultCategories ts), checkOperationFail @@ -695,13 +574,13 @@ checkOperationSuccess ("testfiles" "function_filters_satisfied.0rx") (\ts -> checkCategoryInstances defaultCategories ts), - checkOperationFail + checkOperationSuccess ("testfiles" "function_requires_missed.0rx") (\ts -> checkCategoryInstances defaultCategories ts), - checkOperationFail + checkOperationSuccess ("testfiles" "function_allows_missed.0rx") (\ts -> checkCategoryInstances defaultCategories ts), - checkOperationFail + checkOperationSuccess ("testfiles" "function_defines_missed.0rx") (\ts -> checkCategoryInstances defaultCategories ts), @@ -724,23 +603,23 @@ checkOperationSuccess ("testfiles" "valid_filter_variance.0rx") (\ts -> checkParamVariances defaultCategories ts), - checkOperationFail - ("testfiles" "bad_allows_variance_right.0rx") + checkOperationSuccess + ("testfiles" "allows_variance_right.0rx") (\ts -> checkParamVariances defaultCategories ts), - checkOperationFail - ("testfiles" "bad_defines_variance_right.0rx") + checkOperationSuccess + ("testfiles" "defines_variance_right.0rx") (\ts -> checkParamVariances defaultCategories ts), - checkOperationFail - ("testfiles" "bad_requires_variance_right.0rx") + checkOperationSuccess + ("testfiles" "requires_variance_right.0rx") (\ts -> checkParamVariances defaultCategories ts), - checkOperationFail - ("testfiles" "bad_allows_variance_left.0rx") + checkOperationSuccess + ("testfiles" "allows_variance_left.0rx") (\ts -> checkParamVariances defaultCategories ts), - checkOperationFail - ("testfiles" "bad_defines_variance_left.0rx") + checkOperationSuccess + ("testfiles" "defines_variance_left.0rx") (\ts -> checkParamVariances defaultCategories ts), - checkOperationFail - ("testfiles" "bad_requires_variance_left.0rx") + checkOperationSuccess + ("testfiles" "requires_variance_left.0rx") (\ts -> checkParamVariances defaultCategories ts), checkOperationFail @@ -808,9 +687,6 @@ checkOperationSuccess ("testfiles" "valid_self.0rx") (includeNewTypes defaultCategories >=> const (return ())), - checkOperationSuccess - ("testfiles" "filtered_self.0rx") - (includeNewTypes defaultCategories >=> const (return ())), checkOperationFail ("testfiles" "bad_merge_self.0rx") (includeNewTypes defaultCategories >=> const (return ())), @@ -1008,6 +884,23 @@ [("#x","all")]), checkOperationSuccess + ("testfiles" "inference.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceSuccess tm + [("#x",[])] ["#x"] + [("Interface1","Interface1<#x>")] + [("#x","all")]), + checkOperationSuccess + ("testfiles" "inference.0rx") + (\ts -> do + tm <- includeNewTypes defaultCategories ts + checkInferenceSuccess tm + [("#x",[])] ["#x"] + [("Interface2","Interface2<#x>")] + [("#x","any")]), + + checkOperationSuccess ("testfiles" "delayed_merging.0rx") (\ts -> do tm <- includeNewTypes defaultCategories ts @@ -1206,7 +1099,7 @@ scrapeAllRefines :: [AnyCategory c] -> [(String, String)] scrapeAllRefines = map (show *** show) . concat . map scrapeSingle where - scrapeSingle (ValueInterface _ _ n _ rs _ _) = map ((,) n . vrType) rs + scrapeSingle (ValueInterface _ _ n _ rs _) = map ((,) n . vrType) rs scrapeSingle (ValueConcrete _ _ n _ rs _ _ _) = map ((,) n . vrType) rs scrapeSingle _ = [] @@ -1291,7 +1184,7 @@ checkInferenceSuccess :: CategoryMap SourceContext -> [(String, [String])] -> [String] -> [(String,String)] -> [(String,String)] -> TrackedErrors () checkInferenceSuccess tm pa is ts gs = checkInferenceCommon check tm pa is ts gs where - prefix = show ts ++ " " ++ showParams pa + prefix = show ts ++ " " ++ showFilters pa check gs2 c | isCompilerError c = compilerErrorM $ prefix ++ ":\n" ++ show (getCompilerWarnings c) ++ show (getCompilerError c) | otherwise = getCompilerSuccess c `containsExactly` gs2 @@ -1299,7 +1192,7 @@ checkInferenceFail :: CategoryMap SourceContext -> [(String, [String])] -> [String] -> [(String,String)] -> TrackedErrors () checkInferenceFail tm pa is ts = checkInferenceCommon check tm pa is ts [] where - prefix = show ts ++ " " ++ showParams pa + prefix = show ts ++ " " ++ showFilters pa check _ c | isCompilerError c = return () | otherwise = compilerErrorM $ prefix ++ ": Expected failure\n" diff --git a/src/Test/TypeInstance.hs b/src/Test/TypeInstance.hs --- a/src/Test/TypeInstance.hs +++ b/src/Test/TypeInstance.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 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. @@ -414,19 +414,19 @@ [] "Type4", return $ checkTypeSuccess Resolver - [("#x",["allows Type0"])] + ["#x"] "Type4<[#x&Type0]>", return $ checkTypeSuccess Resolver - [("#x",["allows Type0"])] + ["#x"] "Type4<[#x|Type0]>", return $ checkTypeSuccess Resolver - [("#x",["allows Type0"])] + ["#x"] "Type4<[#x|Type3]>", return $ checkTypeFail Resolver [] "Type5<#x>", return $ checkTypeSuccess Resolver - [("#x",[])] + ["#x"] "Type5<#x>", checkConvertSuccess @@ -547,69 +547,41 @@ "optional Type3", return $ checkTypeSuccess Resolver - [("#x",[])] + ["#x"] "#x", - return $ checkTypeFail Resolver - [("#x",[])] - "Type1<#x>", - return $ checkTypeFail Resolver - [("#x",["requires Type3"])] - "Type1<#x>", - return $ checkTypeFail Resolver - [("#x",["defines Instance0"])] + return $ checkTypeSuccess Resolver + ["#x"] "Type1<#x>", - return $ checkTypeFail Resolver + return $ checkTypeSuccess Resolver [] "Type1", return $ checkTypeSuccess Resolver - [("#x",["requires Type3","defines Instance0"])] + ["#x"] "Type1<#x>", return $ checkTypeSuccess Resolver [] "Type1", - return $ checkTypeFail Resolver + return $ checkTypeSuccess Resolver [] "Type1>", return $ checkTypeSuccess Resolver [] "Type2", - return $ checkTypeFail Resolver + return $ checkTypeSuccess Resolver [] "Type2", - return $ checkTypeFail Resolver + return $ checkTypeSuccess Resolver [] "Type2", return $ checkTypeSuccess Resolver [] "Type4", - return $ checkTypeFail Resolver + return $ checkTypeSuccess Resolver [] "Type4", return $ checkTypeSuccess Resolver - [("#x",["defines Instance1", - "defines Instance1<#x>", - "defines Instance1"])] - "Type2<#x,#x,#x>", - return $ checkTypeFail Resolver - [("#x",["defines Instance1<#x>", - "defines Instance1"])] - "Type2<#x,#x,#x>", - return $ checkTypeFail Resolver - [("#x",["defines Instance1", - "defines Instance1"])] - "Type2<#x,#x,#x>", - return $ checkTypeSuccess Resolver - [("#x",["defines Instance1", - "defines Instance1<#x>"])] - "Type2<#x,#x,#x>", - return $ checkTypeSuccess Resolver - [("#x",["allows Type0", -- Type0 -> #x implies Type3 -> #x - "defines Instance1<#x>"])] - "Type2<#x,#x,#x>", - return $ checkTypeFail Resolver - [("#x",["allows Type3", -- Type3 -> #x doesn't imply Type0 -> #x - "defines Instance1<#x>"])] + ["#x"] "Type2<#x,#x,#x>", return $ checkTypeSuccess Resolver @@ -619,7 +591,7 @@ [] "Type5<#x>", return $ checkTypeSuccess Resolver - [("#x",[])] + ["#x"] "Type5<#x>", return $ checkTypeSuccess Resolver @@ -629,22 +601,22 @@ [] "[Type4&Type1]", return $ checkTypeSuccess Resolver - [("#x",[])] + ["#x"] "[Type5<#x>|Type1]", return $ checkTypeSuccess Resolver - [("#x",[])] + ["#x"] "[Type5<#x>&Type1]", return $ checkTypeSuccess Resolver - [("#x",[])] + ["#x"] "[#x|Type1]", return $ checkTypeSuccess Resolver - [("#x",[])] + ["#x"] "[#x&Type1]", return $ checkTypeFail Resolver - [("#x",[])] + ["#x"] "[Type4|Instance0]", return $ checkTypeFail Resolver - [("#x",[])] + ["#x"] "[Type4&Instance0]", return $ checkTypeSuccess Resolver @@ -654,20 +626,17 @@ [] "[[Type4|Type1]&Type1]", return $ checkTypeSuccess Resolver - [("#x",[])] + ["#x"] "[[Type4&#x]|Type1]", return $ checkTypeSuccess Resolver - [("#x",[])] + ["#x"] "[[Type4|#x]&Type1]", - return $ checkDefinesFail Resolver - [("#x",[])] - "Instance1<#x>", return $ checkDefinesSuccess Resolver - [("#x",["requires Type3"])] + ["#x"] "Instance1<#x>", return $ checkDefinesFail Resolver - [("#x",["defines Instance1<#x>"])] + [] "Instance1<#x>", return $ checkDefinesSuccess Resolver [] @@ -883,9 +852,9 @@ checkConvertSuccess :: [(String, [String])] -> String -> String -> IO (TrackedErrors ()) checkConvertSuccess pa x y = return checked where - prefix = x ++ " -> " ++ y ++ " " ++ showParams pa + prefix = x ++ " -> " ++ y ++ " " ++ showFilters pa checked = do - ([t1,t2],pa2) <- parseTheTest pa [x,y] + ([t1,t2],pa2) <- parseTestWithFilters pa [x,y] check $ checkValueAssignment Resolver pa2 t1 t2 check c | isCompilerError c = compilerErrorM $ prefix ++ ":\n" ++ show (getCompilerError c) @@ -894,7 +863,7 @@ checkInferenceSuccess :: [(String, [String])] -> [String] -> String -> String -> MergeTree (String,String,Variance) -> IO (TrackedErrors ()) checkInferenceSuccess pa is x y gs = checkInferenceCommon check pa is x y gs where - prefix = x ++ " -> " ++ y ++ " " ++ showParams pa + prefix = x ++ " -> " ++ y ++ " " ++ showFilters pa check gs2 c | isCompilerError c = compilerErrorM $ prefix ++ ":\n" ++ show (getCompilerError c) | otherwise = getCompilerSuccess c `checkEquals` gs2 @@ -902,7 +871,7 @@ checkInferenceFail :: [(String, [String])] -> [String] -> String -> String -> IO (TrackedErrors ()) checkInferenceFail pa is x y = checkInferenceCommon check pa is x y (mergeAll []) where - prefix = x ++ " -> " ++ y ++ " " ++ showParams pa + prefix = x ++ " -> " ++ y ++ " " ++ showFilters pa check _ c | isCompilerError c = return () | otherwise = compilerErrorM $ prefix ++ ": Expected failure\n" @@ -914,7 +883,7 @@ checkInferenceCommon check pa is x y gs = return $ checked String -> String -> IO (TrackedErrors ()) checkConvertFail pa x y = return checked where - prefix = x ++ " /> " ++ y ++ " " ++ showParams pa + prefix = x ++ " /> " ++ y ++ " " ++ showFilters pa checked = do - ([t1,t2],pa2) <- parseTheTest pa [x,y] + ([t1,t2],pa2) <- parseTestWithFilters pa [x,y] check $ checkValueAssignment Resolver pa2 t1 t2 check :: TrackedErrors a -> TrackedErrors () check c diff --git a/src/Test/testfiles/allows_variance_left.0rx b/src/Test/testfiles/allows_variance_left.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/allows_variance_left.0rx @@ -0,0 +1,5 @@ +@value interface Interface {} + +concrete Type<|#x> { + #x allows Interface +} diff --git a/src/Test/testfiles/allows_variance_right.0rx b/src/Test/testfiles/allows_variance_right.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/allows_variance_right.0rx @@ -0,0 +1,5 @@ +@value interface Interface<|#x> {} + +concrete Type<#x|> { + #x allows Interface<#x> +} diff --git a/src/Test/testfiles/bad_allows_variance_left.0rx b/src/Test/testfiles/bad_allows_variance_left.0rx deleted file mode 100644 --- a/src/Test/testfiles/bad_allows_variance_left.0rx +++ /dev/null @@ -1,5 +0,0 @@ -@value interface Interface {} - -concrete Type<|#x> { - #x allows Interface -} diff --git a/src/Test/testfiles/bad_allows_variance_right.0rx b/src/Test/testfiles/bad_allows_variance_right.0rx deleted file mode 100644 --- a/src/Test/testfiles/bad_allows_variance_right.0rx +++ /dev/null @@ -1,5 +0,0 @@ -@value interface Interface<|#x> {} - -concrete Type<#x|> { - #x allows Interface<#x> -} diff --git a/src/Test/testfiles/bad_defines_variance_left.0rx b/src/Test/testfiles/bad_defines_variance_left.0rx deleted file mode 100644 --- a/src/Test/testfiles/bad_defines_variance_left.0rx +++ /dev/null @@ -1,5 +0,0 @@ -@type interface Interface {} - -concrete Type<#x|> { - #x defines Interface -} diff --git a/src/Test/testfiles/bad_defines_variance_right.0rx b/src/Test/testfiles/bad_defines_variance_right.0rx deleted file mode 100644 --- a/src/Test/testfiles/bad_defines_variance_right.0rx +++ /dev/null @@ -1,5 +0,0 @@ -@type interface Interface<|#x> {} - -concrete Type<|#x> { - #x defines Interface<#x> -} diff --git a/src/Test/testfiles/bad_requires_variance_left.0rx b/src/Test/testfiles/bad_requires_variance_left.0rx deleted file mode 100644 --- a/src/Test/testfiles/bad_requires_variance_left.0rx +++ /dev/null @@ -1,5 +0,0 @@ -@value interface Interface {} - -concrete Type<#x|> { - #x requires Interface -} diff --git a/src/Test/testfiles/bad_requires_variance_right.0rx b/src/Test/testfiles/bad_requires_variance_right.0rx deleted file mode 100644 --- a/src/Test/testfiles/bad_requires_variance_right.0rx +++ /dev/null @@ -1,5 +0,0 @@ -@value interface Interface<|#x> {} - -concrete Type<|#x> { - #x requires Interface<#x> -} diff --git a/src/Test/testfiles/concrete_instances.0rx b/src/Test/testfiles/concrete_instances.0rx deleted file mode 100644 --- a/src/Test/testfiles/concrete_instances.0rx +++ /dev/null @@ -1,33 +0,0 @@ -// Setup. - -@type interface Type<#x|> { - #x requires Value0 -} - -@value interface Value0 {} - -@value interface Value1<|#y> { - #y requires Value0 -} - -@value interface Value2 { - refines Value0 -} - -@value interface Value3<|#z> { - #z defines Type -} - - -// Tests. - -concrete Object0 { - refines Value2 // -> Value0 - defines Type - refines Value1 -} - -concrete Object1 { - defines Type - refines Value3 -} diff --git a/src/Test/testfiles/concrete_missing_define.0rx b/src/Test/testfiles/concrete_missing_define.0rx deleted file mode 100644 --- a/src/Test/testfiles/concrete_missing_define.0rx +++ /dev/null @@ -1,22 +0,0 @@ -// Setup. - -@type interface Type<#x|> { - #x requires Value0 -} - -@value interface Value0 {} - -@value interface Value1<|#y> { - #y requires Value0 -} - -@value interface Value3<|#z> { - #z defines Type -} - - -// Tests. - -concrete Object1 { - refines Value3 -} diff --git a/src/Test/testfiles/concrete_missing_refine.0rx b/src/Test/testfiles/concrete_missing_refine.0rx deleted file mode 100644 --- a/src/Test/testfiles/concrete_missing_refine.0rx +++ /dev/null @@ -1,23 +0,0 @@ -// Setup. - -@type interface Type<#x|> { - x requires Value0 -} - -@value interface Value0 {} - -@value interface Value1<|#y> { - y requires Value0 -} - -@value interface Value2 { - refines Value0 -} - - -// Tests. - -concrete Object0 { - defines Type - refines Value1 -} diff --git a/src/Test/testfiles/defines_variance_left.0rx b/src/Test/testfiles/defines_variance_left.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/defines_variance_left.0rx @@ -0,0 +1,5 @@ +@type interface Interface {} + +concrete Type<#x|> { + #x defines Interface +} diff --git a/src/Test/testfiles/defines_variance_right.0rx b/src/Test/testfiles/defines_variance_right.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/defines_variance_right.0rx @@ -0,0 +1,5 @@ +@type interface Interface<|#x> {} + +concrete Type<|#x> { + #x defines Interface<#x> +} diff --git a/src/Test/testfiles/filtered_self.0rx b/src/Test/testfiles/filtered_self.0rx deleted file mode 100644 --- a/src/Test/testfiles/filtered_self.0rx +++ /dev/null @@ -1,14 +0,0 @@ -@value interface Foo {} - -@type interface Bar {} - -@value interface Base<|#x> { - #x requires Foo - #x defines Bar -} - -concrete Value<#y|> { - refines Base<#self> - refines Foo - defines Bar -} diff --git a/src/Test/testfiles/function_bad_allows_type.0rx b/src/Test/testfiles/function_bad_allows_type.0rx deleted file mode 100644 --- a/src/Test/testfiles/function_bad_allows_type.0rx +++ /dev/null @@ -1,9 +0,0 @@ -@value interface Interface<#x> { - #x requires Formatted -} - -concrete Type<#x> { - @type something<#y> - #y allows Interface<#x> - () -> () -} diff --git a/src/Test/testfiles/function_bad_arg.0rx b/src/Test/testfiles/function_bad_arg.0rx deleted file mode 100644 --- a/src/Test/testfiles/function_bad_arg.0rx +++ /dev/null @@ -1,9 +0,0 @@ -@value interface Type0 {} - -@value interface Type1<#x> { - #x requires Type0 -} - -concrete Type { - @value something (Type1<#x>) -> () -} diff --git a/src/Test/testfiles/function_bad_defines_type.0rx b/src/Test/testfiles/function_bad_defines_type.0rx deleted file mode 100644 --- a/src/Test/testfiles/function_bad_defines_type.0rx +++ /dev/null @@ -1,9 +0,0 @@ -@type interface Interface<#x> { - #x requires Formatted -} - -concrete Type<#x> { - @type something<#y> - #y defines Interface<#x> - () -> () -} diff --git a/src/Test/testfiles/function_bad_requires_type.0rx b/src/Test/testfiles/function_bad_requires_type.0rx deleted file mode 100644 --- a/src/Test/testfiles/function_bad_requires_type.0rx +++ /dev/null @@ -1,9 +0,0 @@ -@type interface Interface<#x> { - #x requires Formatted -} - -concrete Type<#x> { - @type something<#y> - #y requires Interface<#x> - () -> () -} diff --git a/src/Test/testfiles/function_bad_return.0rx b/src/Test/testfiles/function_bad_return.0rx deleted file mode 100644 --- a/src/Test/testfiles/function_bad_return.0rx +++ /dev/null @@ -1,9 +0,0 @@ -@value interface Type0 {} - -@value interface Type1<#x> { - #x requires Type0 -} - -concrete Type { - @value something () -> (Type1<#x>) -} diff --git a/src/Test/testfiles/function_defines_missed.0rx b/src/Test/testfiles/function_defines_missed.0rx --- a/src/Test/testfiles/function_defines_missed.0rx +++ b/src/Test/testfiles/function_defines_missed.0rx @@ -6,11 +6,9 @@ concrete Type4<#x> { #x requires Type2 - #x allows Type3 #x defines Type1 @type something<#y> #y requires Type2 - #y allows Type3 () -> (Type4<#y>) } diff --git a/src/Test/testfiles/internal_filters.0rx b/src/Test/testfiles/internal_filters.0rx deleted file mode 100644 --- a/src/Test/testfiles/internal_filters.0rx +++ /dev/null @@ -1,7 +0,0 @@ -define Type { - types<#x,#y,#z> { - #x requires Type1 - #y allows Type2 - #z defines Type3 - } -} diff --git a/src/Test/testfiles/internal_params.0rx b/src/Test/testfiles/internal_params.0rx deleted file mode 100644 --- a/src/Test/testfiles/internal_params.0rx +++ /dev/null @@ -1,3 +0,0 @@ -define Type { - types<#x,#y,#z> {} -} diff --git a/src/Test/testfiles/requires_variance_left.0rx b/src/Test/testfiles/requires_variance_left.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/requires_variance_left.0rx @@ -0,0 +1,5 @@ +@value interface Interface {} + +concrete Type<#x|> { + #x requires Interface +} diff --git a/src/Test/testfiles/requires_variance_right.0rx b/src/Test/testfiles/requires_variance_right.0rx new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/requires_variance_right.0rx @@ -0,0 +1,5 @@ +@value interface Interface<|#x> {} + +concrete Type<|#x> { + #x requires Interface<#x> +} diff --git a/src/Test/testfiles/type_instances.0rx b/src/Test/testfiles/type_instances.0rx deleted file mode 100644 --- a/src/Test/testfiles/type_instances.0rx +++ /dev/null @@ -1,33 +0,0 @@ -// Setup. - -@type interface Type<#x|> { - #x requires Value0 -} - -@value interface Value0 {} - -@value interface Value1<|#y> { - #y requires Value0 -} - -@value interface Value2 { - refines Value0 -} - -@value interface Value3<|#z> { - #z defines Type -} - - -// Tests. - -@type interface Object0<#x> { - #x requires Value2 // -> Value0 - #x defines Type<#x> - #x requires Value1<#x> -} - -@type interface Object1<#x> { - #x defines Type - #x requires Value3<#x> -} diff --git a/src/Test/testfiles/type_interface.0rx b/src/Test/testfiles/type_interface.0rx --- a/src/Test/testfiles/type_interface.0rx +++ b/src/Test/testfiles/type_interface.0rx @@ -1,8 +1,4 @@ @type interface Type<#a,#b|#c,#d|#e,#f> { - #a allows Parent - #b requires Type2<#a> - #c defines Equals<#c> - create () -> (optional #x) create2<#y> diff --git a/src/Test/testfiles/type_missing_define.0rx b/src/Test/testfiles/type_missing_define.0rx deleted file mode 100644 --- a/src/Test/testfiles/type_missing_define.0rx +++ /dev/null @@ -1,22 +0,0 @@ -// Setup. - -@type interface Type<#x|> { - #x requires Value0 -} - -@value interface Value0 {} - -@value interface Value1<|#y> { - #y requires Value0 -} - -@value interface Value3<|#z> { - #z defines Type -} - - -// Tests. - -@type interface Object1<#x> { - #x requires Value3<#x> -} diff --git a/src/Test/testfiles/type_missing_refine.0rx b/src/Test/testfiles/type_missing_refine.0rx deleted file mode 100644 --- a/src/Test/testfiles/type_missing_refine.0rx +++ /dev/null @@ -1,23 +0,0 @@ -// Setup. - -@type interface Type<#x|> { - #x requires Value0 -} - -@value interface Value0 {} - -@value interface Value1<|#y> { - #y requires Value0 -} - -@value interface Value2 { - refines Value0 -} - - -// Tests. - -@type interface Object0<#x> { - #x defines Type<#x> - #x requires Value1<#x> -} diff --git a/src/Test/testfiles/value_instances.0rx b/src/Test/testfiles/value_instances.0rx deleted file mode 100644 --- a/src/Test/testfiles/value_instances.0rx +++ /dev/null @@ -1,33 +0,0 @@ -// Setup. - -@type interface Type<#x|> { - #x requires Value0 -} - -@value interface Value0 {} - -@value interface Value1<|#y> { - #y requires Value0 -} - -@value interface Value2 { - refines Value0 -} - -@value interface Value3<|#z> { - #z defines Type -} - - -// Tests. - -@value interface Object0<#x> { - #x requires Value2 // -> Value0 - #x defines Type<#x> - #x requires Value1<#x> -} - -@value interface Object1<#x> { - #x defines Type - #x requires Value3<#x> -} diff --git a/src/Test/testfiles/value_interface.0rx b/src/Test/testfiles/value_interface.0rx --- a/src/Test/testfiles/value_interface.0rx +++ b/src/Test/testfiles/value_interface.0rx @@ -1,9 +1,6 @@ @value interface Type<#a,#b|#c,#d|#e,#f> { refines Parent refines Other,#f> - #a allows Parent - #b requires Type2<#a> - #c defines Equals<#c> get () -> (#x) set (#x) -> () diff --git a/src/Test/testfiles/value_missing_define.0rx b/src/Test/testfiles/value_missing_define.0rx deleted file mode 100644 --- a/src/Test/testfiles/value_missing_define.0rx +++ /dev/null @@ -1,22 +0,0 @@ -// Setup. - -@type interface Type<#x|> { - #x requires Value0 -} - -@value interface Value0 {} - -@value interface Value1<|#y> { - #y requires Value0 -} - -@value interface Value3<|#z> { - #z defines Type -} - - -// Tests. - -@value interface Object1<#x> { - #x requires Value3<#x> -} diff --git a/src/Test/testfiles/value_missing_refine.0rx b/src/Test/testfiles/value_missing_refine.0rx deleted file mode 100644 --- a/src/Test/testfiles/value_missing_refine.0rx +++ /dev/null @@ -1,23 +0,0 @@ -// Setup. - -@type interface Type<#x|> { - #x requires Value0 -} - -@value interface Value0 {} - -@value interface Value1<|#y> { - #y requires Value0 -} - -@value interface Value2 { - refines Value0 -} - - -// Tests. - -@value interface Object0<#x> { - #x defines Type<#x> - #x requires Value1<#x> -} diff --git a/src/Types/Builtin.hs b/src/Types/Builtin.hs --- a/src/Types/Builtin.hs +++ b/src/Types/Builtin.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 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. @@ -19,20 +19,26 @@ {-# LANGUAGE Safe #-} module Types.Builtin ( + ExpressionValue(..), + PrimitiveType(..), boolRequiredValue, charRequiredValue, defaultCategories, defaultCategoryDeps, - emptyValue, + emptyType, floatRequiredValue, formattedRequiredValue, intRequiredValue, + isPrimitiveType, + orderOptionalValue, stringRequiredValue, ) where import qualified Data.Map as Map import qualified Data.Set as Set +import Base.GeneralType +import Base.Positional import Types.TypeCategory import Types.TypeInstance @@ -55,5 +61,39 @@ floatRequiredValue = requiredSingleton BuiltinFloat formattedRequiredValue :: ValueType formattedRequiredValue = requiredSingleton BuiltinFormatted -emptyValue :: ValueType -emptyValue = ValueType OptionalValue minBound +orderOptionalValue :: GeneralInstance -> ValueType +orderOptionalValue t = ValueType OptionalValue $ singleType $ JustTypeInstance $ TypeInstance BuiltinOrder (Positional [t]) + +emptyType :: ValueType +emptyType = ValueType OptionalValue minBound + +data PrimitiveType = + PrimBool | + PrimString | + PrimChar | + PrimInt | + PrimFloat + deriving (Eq,Show) + +isPrimitiveType :: ValueType -> Bool +isPrimitiveType t + | t == boolRequiredValue = True + | t == intRequiredValue = True + | t == floatRequiredValue = True + | t == charRequiredValue = True + | otherwise = False + +data ExpressionValue = + -- Multi argument/return tuple. + OpaqueMulti String | + -- Single value that needs to be wrapped. (Can convert to UnwrappedSingle.) + WrappedSingle String | + -- Single value that will not be wrapped. (Can convert to WrappedSingle.) + UnwrappedSingle String | + -- Primitive value that needs to be boxed. (Can convert to UnboxedPrimitive.) + BoxedPrimitive PrimitiveType String | + -- Primitive value that will not be boxed. (Can convert to BoxedPrimitive.) + UnboxedPrimitive PrimitiveType String | + -- Value with lazy initialization. Requires indirection to get/set. + LazySingle ExpressionValue + deriving (Show) diff --git a/src/Types/DefinedCategory.hs b/src/Types/DefinedCategory.hs --- a/src/Types/DefinedCategory.hs +++ b/src/Types/DefinedCategory.hs @@ -21,9 +21,12 @@ module Types.DefinedCategory ( DefinedCategory(..), DefinedMember(..), + PragmaDefined(..), VariableRule(..), VariableValue(..), isInitialized, + isMembersHidden, + isMembersReadOnly, mapMembers, mergeInternalInheritance, pairProceduresToFunctions, @@ -46,10 +49,9 @@ DefinedCategory { dcContext :: [c], dcName :: CategoryName, - dcParams :: [ValueParam c], + dcPragmas :: [PragmaDefined c], dcRefines :: [ValueRefine c], dcDefines :: [ValueDefine c], - dcParamFilter :: [ParamFilter c], dcMembers :: [DefinedMember c], dcProcedures :: [ExecutableProcedure c], dcFunctions :: [ScopedFunction c] @@ -71,6 +73,25 @@ check Nothing = False check _ = True +data PragmaDefined c = + MembersReadOnly { + mroContext :: [c], + mroMembers :: [VariableName] + } | + MembersHidden { + mhContext :: [c], + mhMembers :: [VariableName] + } + deriving (Show) + +isMembersReadOnly :: PragmaDefined c -> Bool +isMembersReadOnly (MembersReadOnly _ _) = True +isMembersReadOnly _ = False + +isMembersHidden :: PragmaDefined c -> Bool +isMembersHidden (MembersHidden _ _) = True +isMembersHidden _ = False + data VariableRule c = VariableDefault | VariableReadOnly { @@ -164,8 +185,9 @@ getPair _ _ = undefined mapMembers :: (Show c, CollectErrorsM m) => - [DefinedMember c] -> m (Map.Map VariableName (VariableValue c)) -mapMembers ms = foldr update (return Map.empty) ms where + Map.Map VariableName [c] -> Map.Map VariableName [c] -> [DefinedMember c] -> + m (Map.Map VariableName (VariableValue c)) +mapMembers readOnly hidden ms = foldr update (return Map.empty) ms where update m ma = do ma' <- ma case dmName m `Map.lookup` ma' of @@ -175,7 +197,12 @@ formatFullContextBrace (dmContext m) ++ " is already defined" ++ formatFullContextBrace (vvContext m0) - return $ Map.insert (dmName m) (VariableValue (dmContext m) (dmScope m) (dmType m) VariableDefault) ma' + return $ Map.insert (dmName m) (VariableValue (dmContext m) (dmScope m) (dmType m) (memberRule m)) ma' + memberRule m = + case (dmName m `Map.lookup` hidden,dmName m `Map.lookup` readOnly) of + (Just c,_) -> VariableHidden c + (_,Just c) -> VariableReadOnly c + _ -> VariableDefault -- TODO: Most of this duplicates parts of flattenAllConnections. mergeInternalInheritance :: (Show c, CollectErrorsM m) => diff --git a/src/Types/Function.hs b/src/Types/Function.hs --- a/src/Types/Function.hs +++ b/src/Types/Function.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 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. @@ -28,6 +28,7 @@ import Data.List (group,intercalate,sort) import Control.Monad (when) import qualified Data.Map as Map +import qualified Data.Set as Set import Base.CompilerError import Base.GeneralType @@ -55,24 +56,23 @@ showFilters (n,fs) = map (\f -> show n ++ " " ++ show f ++ " ") fs validatateFunctionType :: (CollectErrorsM m, TypeResolver r) => - r -> ParamFilters -> ParamVariances -> FunctionType -> m () -validatateFunctionType r fm vm (FunctionType as rs ps fa) = do + r -> Set.Set ParamName -> ParamVariances -> FunctionType -> m () +validatateFunctionType r params vm (FunctionType as rs ps fa) = do mapCompilerM_ checkCount $ group $ sort $ pValues ps mapCompilerM_ checkHides $ pValues ps - paired <- processPairs alwaysPair ps fa - let allFilters = Map.union fm (Map.fromList paired) + let allParams = Set.union params (Set.fromList $ pValues ps) expanded <- fmap concat $ processPairs (\n fs -> return $ zip (repeat n) fs) ps fa - mapCompilerM_ (checkFilterType allFilters) expanded + mapCompilerM_ (checkFilterType allParams) expanded mapCompilerM_ checkFilterVariance expanded - mapCompilerM_ (checkArg allFilters) $ pValues as - mapCompilerM_ (checkReturn allFilters) $ pValues rs + mapCompilerM_ (checkArg allParams) $ pValues as + mapCompilerM_ (checkReturn allParams) $ pValues rs where allVariances = Map.union vm (Map.fromList $ zip (pValues ps) (repeat Invariant)) checkCount xa@(x:_:_) = compilerErrorM $ "Function parameter " ++ show x ++ " occurs " ++ show (length xa) ++ " times" checkCount _ = return () checkHides n = - when (n `Map.member` fm) $ + when (n `Set.member` params) $ compilerErrorM $ "Function parameter " ++ show n ++ " hides a category-level parameter" checkFilterType fa2 (n,f) = validateTypeFilter r fa2 f ParamFilters -> ParamValues -> Positional GeneralInstance -> FunctionType -> m FunctionType assignFunctionParams r fm pm ts (FunctionType as rs ps fa) = do - mapCompilerM_ (validateGeneralInstance r fm) $ pValues ts + mapCompilerM_ (validateGeneralInstanceForCall r fm) $ pValues ts assigned <- fmap Map.fromList $ processPairs alwaysPair ps ts let pa = pm `Map.union` assigned fa' <- fmap Positional $ mapCompilerM (assignFilters pa) (pValues fa) diff --git a/src/Types/Procedure.hs b/src/Types/Procedure.hs --- a/src/Types/Procedure.hs +++ b/src/Types/Procedure.hs @@ -24,12 +24,14 @@ ExecutableProcedure(..), Expression(..), ExpressionStart(..), + ExpressionType, FunctionCall(..), FunctionQualifier(..), FunctionSpec(..), IfElifElse(..), InputValue(..), InstanceOrInferred(..), + IteratedLoop(..), MacroName(..), Operator(..), OutputValue(..), @@ -44,7 +46,6 @@ ValueOperation(..), VariableName(..), VoidExpression(..), - WhileLoop(..), assignableName, getExpressionContext, getOperatorContext, @@ -62,6 +63,7 @@ import Data.List (intercalate) import Base.Positional +import Types.Builtin import Types.TypeCategory import Types.TypeInstance @@ -205,7 +207,7 @@ data VoidExpression c = Conditional (IfElifElse c) | - Loop (WhileLoop c) | + Loop (IteratedLoop c) | WithScope (ScopedBlock c) | Unconditional (Procedure c) | LineComment String @@ -217,8 +219,9 @@ TerminateConditional deriving (Show) -data WhileLoop c = - WhileLoop [c] (Expression c) (Procedure c) (Maybe (Procedure c)) +data IteratedLoop c = + WhileLoop [c] (Expression c) (Procedure c) (Maybe (Procedure c)) | + TraverseLoop [c] (Expression c) [c] (Assignable c) (Procedure c) deriving (Show) data ScopedBlock c = @@ -230,9 +233,12 @@ Literal (ValueLiteral c) | UnaryExpression [c] (Operator c) (Expression c) | InfixExpression [c] (Expression c) (Operator c) (Expression c) | - InitializeValue [c] (Maybe TypeInstance) (Positional GeneralInstance) (Positional (Expression c)) + InitializeValue [c] (Maybe TypeInstance) (Positional (Expression c)) | + RawExpression ExpressionType ExpressionValue deriving (Show) +type ExpressionType = Positional ValueType + data FunctionQualifier c = CategoryFunction [c] CategoryName | TypeFunction [c] TypeInstanceOrParam | @@ -272,7 +278,8 @@ getExpressionContext (Literal l) = getValueLiteralContext l getExpressionContext (UnaryExpression c _ _) = c getExpressionContext (InfixExpression c _ _ _) = c -getExpressionContext (InitializeValue c _ _ _) = c +getExpressionContext (InitializeValue c _ _) = c +getExpressionContext (RawExpression _ _) = [] data FunctionCall c = FunctionCall [c] FunctionName (Positional (InstanceOrInferred c)) (Positional (Expression c)) diff --git a/src/Types/TypeCategory.hs b/src/Types/TypeCategory.hs --- a/src/Types/TypeCategory.hs +++ b/src/Types/TypeCategory.hs @@ -51,6 +51,7 @@ getCategoryName, getCategoryNamespace, getCategoryParamMap, + getCategoryParamSet, getCategoryParams, getCategoryRefines, getConcreteCategory, @@ -107,7 +108,6 @@ viName :: CategoryName, viParams :: [ValueParam c], viRefines :: [ValueRefine c], - viParamFilter :: [ParamFilter c], viFunctions :: [ScopedFunction c] } | InstanceInterface { @@ -115,7 +115,6 @@ iiNamespace :: Namespace, iiName :: CategoryName, iiParams :: [ValueParam c], - iiParamFilter :: [ParamFilter c], iiFunctions :: [ScopedFunction c] } | ValueConcrete { @@ -138,17 +137,15 @@ instance Show c => Show (AnyCategory c) where show = format where - format (ValueInterface cs ns n ps rs vs fs) = + format (ValueInterface cs ns n ps rs fs) = "@value interface " ++ show n ++ formatParams ps ++ namespace ns ++ " { " ++ formatContext cs ++ "\n" ++ (intercalate "\n\n" $ map (\r -> " " ++ formatRefine r) rs ++ - map (\v -> " " ++ formatValue v) vs ++ map (\f -> formatInterfaceFunc f) fs) ++ "\n}\n" - format (InstanceInterface cs ns n ps vs fs) = + format (InstanceInterface cs ns n ps fs) = "@type interface " ++ show n ++ formatParams ps ++ namespace ns ++ " { " ++ formatContext cs ++ (intercalate "\n\n" $ - map (\v -> " " ++ formatValue v) vs ++ map (\f -> formatInterfaceFunc f) fs) ++ "\n}\n" format (ValueConcrete cs ns n ps rs ds vs fs) = @@ -178,48 +175,48 @@ formatConcreteFunc f = showFunctionInContext (show (sfScope f) ++ " ") " " f getCategoryName :: AnyCategory c -> CategoryName -getCategoryName (ValueInterface _ _ n _ _ _ _) = n -getCategoryName (InstanceInterface _ _ n _ _ _) = n +getCategoryName (ValueInterface _ _ n _ _ _) = n +getCategoryName (InstanceInterface _ _ n _ _) = n getCategoryName (ValueConcrete _ _ n _ _ _ _ _) = n getCategoryContext :: AnyCategory c -> [c] -getCategoryContext (ValueInterface c _ _ _ _ _ _) = c -getCategoryContext (InstanceInterface c _ _ _ _ _) = c +getCategoryContext (ValueInterface c _ _ _ _ _) = c +getCategoryContext (InstanceInterface c _ _ _ _) = c getCategoryContext (ValueConcrete c _ _ _ _ _ _ _) = c getCategoryNamespace :: AnyCategory c -> Namespace -getCategoryNamespace (ValueInterface _ ns _ _ _ _ _) = ns -getCategoryNamespace (InstanceInterface _ ns _ _ _ _) = ns +getCategoryNamespace (ValueInterface _ ns _ _ _ _) = ns +getCategoryNamespace (InstanceInterface _ ns _ _ _) = ns getCategoryNamespace (ValueConcrete _ ns _ _ _ _ _ _) = ns setCategoryNamespace :: Namespace -> AnyCategory c -> AnyCategory c -setCategoryNamespace ns (ValueInterface c _ n ps rs vs fs) = (ValueInterface c ns n ps rs vs fs) -setCategoryNamespace ns (InstanceInterface c _ n ps vs fs) = (InstanceInterface c ns n ps vs fs) +setCategoryNamespace ns (ValueInterface c _ n ps rs fs) = (ValueInterface c ns n ps rs fs) +setCategoryNamespace ns (InstanceInterface c _ n ps fs) = (InstanceInterface c ns n ps fs) setCategoryNamespace ns (ValueConcrete c _ n ps rs ds vs fs) = (ValueConcrete c ns n ps rs ds vs fs) getCategoryParams :: AnyCategory c -> [ValueParam c] -getCategoryParams (ValueInterface _ _ _ ps _ _ _) = ps -getCategoryParams (InstanceInterface _ _ _ ps _ _) = ps +getCategoryParams (ValueInterface _ _ _ ps _ _) = ps +getCategoryParams (InstanceInterface _ _ _ ps _) = ps getCategoryParams (ValueConcrete _ _ _ ps _ _ _ _) = ps getCategoryRefines :: AnyCategory c -> [ValueRefine c] -getCategoryRefines (ValueInterface _ _ _ _ rs _ _) = rs -getCategoryRefines (InstanceInterface _ _ _ _ _ _) = [] +getCategoryRefines (ValueInterface _ _ _ _ rs _) = rs +getCategoryRefines (InstanceInterface _ _ _ _ _) = [] getCategoryRefines (ValueConcrete _ _ _ _ rs _ _ _) = rs getCategoryDefines :: AnyCategory c -> [ValueDefine c] -getCategoryDefines (ValueInterface _ _ _ _ _ _ _) = [] -getCategoryDefines (InstanceInterface _ _ _ _ _ _) = [] +getCategoryDefines (ValueInterface _ _ _ _ _ _) = [] +getCategoryDefines (InstanceInterface _ _ _ _ _) = [] getCategoryDefines (ValueConcrete _ _ _ _ _ ds _ _) = ds getCategoryFilters :: AnyCategory c -> [ParamFilter c] -getCategoryFilters (ValueInterface _ _ _ _ _ vs _) = vs -getCategoryFilters (InstanceInterface _ _ _ _ vs _) = vs +getCategoryFilters (ValueInterface _ _ _ _ _ _) = [] +getCategoryFilters (InstanceInterface _ _ _ _ _) = [] getCategoryFilters (ValueConcrete _ _ _ _ _ _ vs _) = vs getCategoryFunctions :: AnyCategory c -> [ScopedFunction c] -getCategoryFunctions (ValueInterface _ _ _ _ _ _ fs) = fs -getCategoryFunctions (InstanceInterface _ _ _ _ _ fs) = fs +getCategoryFunctions (ValueInterface _ _ _ _ _ fs) = fs +getCategoryFunctions (InstanceInterface _ _ _ _ fs) = fs getCategoryFunctions (ValueConcrete _ _ _ _ _ _ _ fs) = fs instanceFromCategory :: AnyCategory c -> GeneralInstance @@ -246,11 +243,11 @@ filters2 = concat $ map (fromFilter . pfFilter) $ sfFilters f isValueInterface :: AnyCategory c -> Bool -isValueInterface (ValueInterface _ _ _ _ _ _ _) = True +isValueInterface (ValueInterface _ _ _ _ _ _) = True isValueInterface _ = False isInstanceInterface :: AnyCategory c -> Bool -isInstanceInterface (InstanceInterface _ _ _ _ _ _) = True +isInstanceInterface (InstanceInterface _ _ _ _ _) = True isInstanceInterface _ = False isValueConcrete :: AnyCategory c -> Bool @@ -513,6 +510,9 @@ defaultMap <- getFilterMap (getCategoryParams t) (getCategoryFilters t) return $ Map.insert ParamSelf (getSelfFilters t) defaultMap +getCategoryParamSet :: CollectErrorsM m => AnyCategory c -> m (Set.Set ParamName) +getCategoryParamSet = return . Set.fromList . ([ParamSelf] ++) . map vpParam . getCategoryParams + -- TODO: Use this where it's needed in this file. getFunctionFilterMap :: CollectErrorsM m => ScopedFunction c -> m ParamFilters getFunctionFilterMap f = getFilterMap (pValues $ sfParams f) (sfFilters f) @@ -541,7 +541,7 @@ tm <- declareAllTypes tm0 ts collectAllM_ (map (checkSingle tm) ts) where - checkSingle tm (ValueInterface c _ n _ rs _ _) = do + checkSingle tm (ValueInterface c _ n _ rs _) = do let ts2 = map (\r -> (vrContext r,tiName $ vrType r)) rs is <- mapCompilerM (getCategory tm) ts2 collectAllM_ (map (valueRefinesInstanceError c n) is) @@ -599,7 +599,7 @@ CategoryMap c -> [AnyCategory c] -> m () 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 + checker us (ValueInterface c _ n _ rs _) = do failIfCycle n c us let ts2 = map (\r -> (vrContext r,tiName $ vrType r)) rs is <- mapCompilerM (getValueCategory tm) ts2 @@ -627,21 +627,17 @@ 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 + checkCategory r t@(ValueInterface c _ n ps rs _) = categoryContext t ??> do noDuplicates c n ps let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) ps collectAllM_ (map (checkRefine r vm) rs) - mapCompilerM_ (checkFilterVariance r vm) fa - checkCategory r t@(ValueConcrete c _ n ps rs ds fa _) = categoryContext t ??> do + checkCategory r t@(ValueConcrete c _ n ps rs ds _ _) = categoryContext t ??> do noDuplicates c n ps let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) ps collectAllM_ (map (checkRefine r vm) rs) collectAllM_ (map (checkDefine r vm) ds) - mapCompilerM_ (checkFilterVariance r vm) fa - checkCategory r t@(InstanceInterface c _ n ps fa _) = categoryContext t ??> do + checkCategory _ t@(InstanceInterface c _ n ps _) = categoryContext t ??> do noDuplicates c n ps - let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) ps - mapCompilerM_ (checkFilterVariance r vm) fa noDuplicates c n ps = collectAllM_ (map checkCount $ group $ sort $ map vpParam ps) where checkCount xa@(x:_:_) = compilerErrorM $ "Param " ++ show x ++ " occurs " ++ show (length xa) ++ @@ -653,30 +649,6 @@ checkDefine r vm (ValueDefine c t) = validateDefinesVariance r vm Covariant t do - case n `Map.lookup` vs of - Just Contravariant -> compilerErrorM $ "Contravariant param " ++ show n ++ - " cannot have a requires filter" - Nothing -> compilerErrorM $ "Param " ++ show n ++ " is undefined" - _ -> return () - 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 - Just Covariant -> compilerErrorM $ "Covariant param " ++ show n ++ - " cannot have an allows filter" - Nothing -> compilerErrorM $ "Param " ++ show n ++ " is undefined" - _ -> return () - 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 - Just Contravariant -> compilerErrorM $ "Contravariant param " ++ show n ++ - " cannot have a defines filter" - Nothing -> compilerErrorM $ "Param " ++ show n ++ " is undefined" - _ -> return () - validateDefinesVariance r vs Contravariant t checkCategoryInstances :: (Show c, CollectErrorsM m) => CategoryMap c -> [AnyCategory c] -> m () @@ -686,12 +658,11 @@ mapCompilerM_ (checkSingle r) ts where checkSingle r t = do - let pa = Set.fromList $ map vpParam $ getCategoryParams t - fm <- getCategoryFilterMap t + pa <- getCategoryParamSet t mapCompilerM_ (checkFilterParam pa) (getCategoryFilters t) - mapCompilerM_ (checkRefine r fm) (getCategoryRefines t) - mapCompilerM_ (checkDefine r fm) (getCategoryDefines t) - mapCompilerM_ (checkFilter r fm) (getCategoryFilters t) + mapCompilerM_ (checkRefine r pa) (getCategoryRefines t) + mapCompilerM_ (checkDefine r pa) (getCategoryDefines t) + mapCompilerM_ (checkFilter r pa) (getCategoryFilters t) mapCompilerM_ (validateCategoryFunction r t) (getCategoryFunctions t) checkFilterParam pa (ParamFilter c n _) = when (not $ n `Set.member` pa) $ @@ -709,14 +680,14 @@ validateCategoryFunction :: (Show c, CollectErrorsM m, TypeResolver r) => r -> AnyCategory c -> ScopedFunction c -> m () validateCategoryFunction r t f = do - fm <- getCategoryFilterMap t + pa <- getCategoryParamSet t let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t message ??> do funcType <- parsedToFunctionType f case sfScope f of - CategoryScope -> validatateFunctionType r Map.empty Map.empty funcType - TypeScope -> validatateFunctionType r fm vm funcType - ValueScope -> validatateFunctionType r fm vm funcType + CategoryScope -> validatateFunctionType r Set.empty Map.empty funcType + TypeScope -> validatateFunctionType r pa vm funcType + ValueScope -> validatateFunctionType r pa vm funcType _ -> return () getFunctionFilterMap f >>= disallowBoundedParams where message @@ -805,9 +776,9 @@ tm <- u t' <- preMergeSingle tm t return $ Map.insert (getCategoryName t') t' tm - preMergeSingle tm (ValueInterface c ns n ps rs vs fs) = do + preMergeSingle tm (ValueInterface c ns n ps rs fs) = do rs' <- fmap concat $ mapCompilerM (getRefines tm) rs - return $ ValueInterface c ns n ps rs' vs fs + return $ ValueInterface c ns n ps rs' fs preMergeSingle tm (ValueConcrete c ns n ps rs ds vs fs) = do rs' <- fmap concat $ mapCompilerM (getRefines tm) rs return $ ValueConcrete c ns n ps rs' ds vs fs @@ -818,7 +789,7 @@ "In category " ++ show (getCategoryName t) ++ 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 + updateSingle r tm t@(ValueInterface c ns n ps rs fs) = do fm <- getCategoryFilterMap t let pm = getCategoryParamMap t rs' <- fmap concat $ mapCompilerM (getRefines tm) rs @@ -827,7 +798,7 @@ checkMerged r fm rs rs'' -- Only merge from direct parents. fs' <- mergeFunctions r tm pm fm rs [] fs - return $ ValueInterface c ns n ps rs'' vs fs' + return $ ValueInterface c ns n ps rs'' fs' -- TODO: Remove duplication below and/or have separate tests. updateSingle r tm t@(ValueConcrete c ns n ps rs ds vs fs) = do fm <- getCategoryFilterMap t @@ -1078,21 +1049,20 @@ data GuessRange a = GuessRange { - grLower :: a, - grUpper :: a + grLower :: Maybe a, + grUpper :: Maybe a } deriving (Eq,Ord) -instance (Bounded a, Eq a, Show a) => Show (GuessRange a) where - show (GuessRange lo hi) - | lo == minBound && hi == maxBound = "Literally anything is possible" - | lo == minBound = "Something at or below " ++ show hi - | hi == maxBound = "Something at or above " ++ show lo - | otherwise = "Something between " ++ show lo ++ " and " ++ show hi +instance Show a => Show (GuessRange a) where + show (GuessRange Nothing Nothing) = "Literally anything is possible" + show (GuessRange Nothing (Just hi)) = "Something at or below " ++ show hi + show (GuessRange (Just lo) Nothing) = "Something at or above " ++ show lo + show (GuessRange (Just lo) (Just hi)) = "Something between " ++ show lo ++ " and " ++ show hi -data GuessUnion a = +data GuessUnion = GuessUnion { - guGuesses :: [GuessRange a] + guGuesses :: [GuessRange GeneralInstance] } mergeInferredTypes :: (CollectErrorsM m, TypeResolver r) => @@ -1105,9 +1075,9 @@ (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] + leafOp (InferredTypeGuess _ t Covariant) = return $ GuessUnion [GuessRange (Just t) Nothing] + leafOp (InferredTypeGuess _ t Contravariant) = return $ GuessUnion [GuessRange Nothing (Just t)] + leafOp (InferredTypeGuess _ t _) = return $ GuessUnion [GuessRange (Just t) (Just t)] anyOp = fmap (GuessUnion . concat . map guGuesses) . collectAllM allOp = collectAllM >=> prodAll prodAll [] = return $ GuessUnion [] @@ -1128,13 +1098,17 @@ hiZ <- tryMerge Contravariant hiX hiY return [GuessRange loZ hiZ] else return [] - convertsTo t1 t2 = isCompilerSuccessM $ 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, + convertsTo Nothing _ = return True + convertsTo _ Nothing = return True + convertsTo (Just t1) (Just t2) = isCompilerSuccessM $ checkGeneralMatch r f Covariant t1 t2 + tryMerge _ Nothing t2 = return t2 + tryMerge _ t1 Nothing = return t1 + tryMerge v (Just t1) (Just t2) = collectFirstM [ + checkGeneralMatch r f v t1 t2 >> return (Just t2), + checkGeneralMatch r f v t2 t1 >> return (Just t1), return $ case v of - Covariant -> mergeAny [t1,t2] - Contravariant -> mergeAll [t1,t2] + Covariant -> Just $ mergeAny [t1,t2] + Contravariant -> Just $ mergeAll [t1,t2] _ -> undefined ] simplifyUnion [] = return [] @@ -1163,37 +1137,31 @@ (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 - _ -> compilerErrorM (show g) do - let checkLo = checkSubFilters i lo - let checkHi = checkSubFilters i hi - pLo <- isCompilerErrorM checkLo - pHi <- isCompilerErrorM checkHi - case (pLo,pHi) of - (True,True) -> collectAllM_ [checkLo,checkHi] >> emptyErrorM - (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 + filterGuess i g@(GuessRange (Just lo) Nothing) = checkSubFilters i lo >> return g + filterGuess i g@(GuessRange Nothing (Just hi)) = checkSubFilters i hi >> return g + filterGuess i g@(GuessRange (Just lo) (Just hi)) = do + let checkLo = checkSubFilters i lo + let checkHi = checkSubFilters i hi + pLo <- isCompilerErrorM checkLo + pHi <- isCompilerErrorM checkHi + case (pLo,pHi) of + (True,True) -> collectAllM_ [checkLo,checkHi] >> emptyErrorM + (True,_) -> return $ GuessRange Nothing (Just hi) + (_,True) -> return $ GuessRange (Just lo) Nothing + _ -> return g + filterGuess _ _ = emptyErrorM checkSubFilters i t = "In guess " ++ show t ++ " for param " ++ show i ??> do let ps' = Map.insert i t ps fs <- ff `filterLookup` i diff --git a/src/Types/TypeInstance.hs b/src/Types/TypeInstance.hs --- a/src/Types/TypeInstance.hs +++ b/src/Types/TypeInstance.hs @@ -71,14 +71,17 @@ validateDefinesInstance, validateDefinesVariance, validateGeneralInstance, + validateGeneralInstanceForCall, validateInstanceVariance, - validateTypeFilter, validateTypeInstance, + validateTypeInstanceForCall, + validateTypeFilter, ) where import Control.Monad (when) import Data.List (intercalate) import qualified Data.Map as Map +import qualified Data.Set as Set import Base.CompilerError import Base.GeneralType @@ -134,6 +137,7 @@ BuiltinFloat | BuiltinString | BuiltinFormatted | + BuiltinOrder | CategoryNone instance Show CategoryName where @@ -144,6 +148,7 @@ show BuiltinFloat = "Float" show BuiltinString = "String" show BuiltinFormatted = "Formatted" + show BuiltinOrder = "Order" show CategoryNone = "(none)" instance Eq CategoryName where @@ -349,25 +354,26 @@ checkValueTypeMatch :: (CollectErrorsM m, TypeResolver r) => 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 +checkValueTypeMatch r f v (ValueType r1 t1) (ValueType r2 t2) = result where + result = do + when (not $ storageDir `allowsVariance` v) $ compilerErrorM "Incompatible storage modifiers" + checkGeneralMatch r f v t1 t2 storageDir | r1 > r2 = Covariant | r1 < r2 = Contravariant | otherwise = Invariant - result = do - when (not $ storageDir `allowsVariance` v) $ compilerErrorM "Incompatible storage modifiers" - checkGeneralMatch r f v t1 t2 checkGeneralMatch :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> Variance -> GeneralInstance -> GeneralInstance -> m (MergeTree InferredTypeGuess) -checkGeneralMatch r f v t1 t2 = do - ss <- collectFirstM [fmap Just bothSingle,return Nothing] - collectFirstM [matchInferredRight,getMatcher ss] where +checkGeneralMatch r f v t1 t2 = message !!> result where + result = do + ss <- collectFirstM [fmap Just bothSingle,return Nothing] + collectFirstM [matchInferredRight,getMatcher ss] + message + | v == Covariant = "Cannot convert " ++ show t1 ++ " -> " ++ show t2 + | v == Contravariant = "Cannot convert " ++ show t1 ++ " <- " ++ show t2 + | otherwise = "Cannot convert " ++ show t1 ++ " <-> " ++ show t2 matchNormal Invariant = mergeAllM [matchNormal Contravariant,matchNormal Covariant] matchNormal Contravariant = @@ -540,32 +546,20 @@ show n1 ++ " <- " ++ show n2 checkConstraintToConstraint _ _ _ = undefined -validateGeneralInstance :: (CollectErrorsM m, TypeResolver r) => +validateGeneralInstanceForCall :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> GeneralInstance -> m () -validateGeneralInstance r f = reduceMergeTree collectAllM_ collectAllM_ validateSingle where - validateSingle (JustTypeInstance t) = validateTypeInstance r f t +validateGeneralInstanceForCall r f = reduceMergeTree collectAllM_ collectAllM_ validateSingle where + validateSingle (JustTypeInstance t) = validateTypeInstanceForCall r f t validateSingle (JustParamName _ n) = when (not $ n `Map.member` f) $ compilerErrorM $ "Param " ++ show n ++ " not found" validateSingle (JustInferredType n) = compilerErrorM $ "Inferred param " ++ show n ++ " is not allowed here" -validateTypeInstance :: (CollectErrorsM m, TypeResolver r) => +validateTypeInstanceForCall :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> TypeInstance -> m () -validateTypeInstance r f t@(TypeInstance _ ps) = do +validateTypeInstanceForCall r f t@(TypeInstance _ ps) = do fa <- trTypeFilters r t processPairs_ (validateAssignment r f) ps fa - mapCompilerM_ (validateGeneralInstance r f) (pValues ps) - r -> ParamFilters -> DefinesInstance -> m () -validateDefinesInstance r f t@(DefinesInstance _ ps) = do - fa <- trDefinesFilters r t - processPairs_ (validateAssignment r f) ps fa - mapCompilerM_ (validateGeneralInstance r f) (pValues ps) - r -> ParamFilters -> TypeFilter -> m () -validateTypeFilter r f (TypeFilter _ t) = validateGeneralInstance r f t -validateTypeFilter r f (DefinesFilter t) = validateDefinesInstance r f t + mapCompilerM_ (validateGeneralInstanceForCall r f) (pValues ps) r -> ParamFilters -> GeneralInstance -> [TypeFilter] -> m () @@ -596,6 +590,31 @@ variance <- trVariance r n2 processPairs_ (\v2 (p1,p2) -> checkGeneralMatch r f v2 p1 p2) variance (Positional paired) | otherwise = compilerErrorM $ "Constraint " ++ show f1 ++ " does not imply " ++ show f2 + +validateGeneralInstance :: (CollectErrorsM m, TypeResolver r) => + r -> Set.Set ParamName -> GeneralInstance -> m () +validateGeneralInstance r params = reduceMergeTree collectAllM_ collectAllM_ validateSingle where + validateSingle (JustTypeInstance t) = validateTypeInstance r params t + validateSingle (JustParamName _ n) = when (not $ n `Set.member` params) $ + compilerErrorM $ "Param " ++ show n ++ " not found" + validateSingle (JustInferredType n) = compilerErrorM $ "Inferred param " ++ show n ++ " is not allowed here" + +validateTypeInstance :: (CollectErrorsM m, TypeResolver r) => + r -> Set.Set ParamName -> TypeInstance -> m () +validateTypeInstance r params t@(TypeInstance _ ps) = do + _ <- trTypeFilters r t -- This just ensures that t exists. + mapCompilerM_ (validateGeneralInstance r params) (pValues ps) + r -> Set.Set ParamName -> DefinesInstance -> m () +validateDefinesInstance r params t@(DefinesInstance _ ps) = do + _ <- trDefinesFilters r t -- This just ensures that t exists. + mapCompilerM_ (validateGeneralInstance r params) (pValues ps) + r -> Set.Set ParamName -> TypeFilter -> m () +validateTypeFilter r params (TypeFilter _ t) = validateGeneralInstance r params t +validateTypeFilter r params (DefinesFilter t) = validateDefinesInstance r params t validateInstanceVariance :: (CollectErrorsM m, TypeResolver r) => r -> ParamVariances -> Variance -> GeneralInstance -> m () diff --git a/tests/builtin-types.0rt b/tests/builtin-types.0rt --- a/tests/builtin-types.0rt +++ b/tests/builtin-types.0rt @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 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. @@ -219,7 +219,7 @@ } } -unittest asFloar { +unittest asFloat { if (present(reduce("a"))) { fail("Failed") } @@ -231,7 +231,19 @@ } } +unittest defaultOrder { + if (!present(reduce>("a"))) { + fail("Failed") + } +} +unittest subSequence { + if (!present(reduce("a"))) { + fail("Failed") + } +} + + testcase "interface implementations" { success } @@ -472,6 +484,18 @@ if (("abc\x00def").readAt(4) != 'd') { fail("Failed") } +} + +unittest traverseString { + Int index <- 0 + String value <- "abcdefg" + + traverse (value.defaultOrder() -> Char c) { + \ Testing.checkEquals(c,value.readAt(index)) + index <- index+1 + } + + \ Testing.checkEquals(index,7) } diff --git a/tests/cli-tests.sh b/tests/cli-tests.sh --- a/tests/cli-tests.sh +++ b/tests/cli-tests.sh @@ -1,7 +1,7 @@ #!/usr/bin/env bash # ------------------------------------------------------------------------------ -# Copyright 2020 Kevin P. Barry +# Copyright 2020-2021 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. @@ -38,6 +38,11 @@ "$@" 2>&1 } +execute_noredir() { + show_message "Executing:" $(printf ' %q' "$@") + "$@" +} + do_zeolite() { execute "${ZEOLITE[@]}" "$@" } @@ -205,7 +210,7 @@ test_templates() { - execute rm -f $ZEOLITE_PATH/tests/templates/Extension_Templated.cpp + execute rm -f $ZEOLITE_PATH/tests/templates/Extension_*.cpp do_zeolite -p "$ZEOLITE_PATH" --templates tests/templates do_zeolite -p "$ZEOLITE_PATH" -r tests/templates do_zeolite -p "$ZEOLITE_PATH" -t tests/templates @@ -303,9 +308,9 @@ local name='Cli Tests' rm -f "$binary" do_zeolite -p "$ZEOLITE_PATH" -I lib/util -m HelloDemo example/hello -f - local output=$(echo "$name" | "$binary" 2>&1) + local output=$(echo "$name" | execute_noredir "$binary" 2>&1) if ! echo "$output" | egrep -q "\"$name\""; then - show_message "Expected \"$name\" in output:" + show_message "Expected \"$name\" in HelloDemo output:" echo "$output" 1>&2 return 1 fi @@ -318,6 +323,28 @@ } +test_example_primes() { + local binary="$ZEOLITE_PATH/example/primes/PrimesDemo" + local expected='2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97,101,103,107,109,113,127,131,137,139,149,151,157,163,167,173,179,181,191,193,197,199,211,223,227,229,233,239,241,251,257,263,269,271,277,281,283,293,307,311,313,317,331,337,347,349,353,359,367,373,379,383,389,397,401,409,419,421,431,433,439,443,449,457,461,463,467,479,487,491,499,503,509,521,523,541,' + rm -f "$binary" + local temp=$(execute mktemp) + do_zeolite -p "$ZEOLITE_PATH" -r example/primes -f + { + echo; + sleep 0.01; + echo; + echo "exit"; + } | execute_noredir "$binary" 2> /dev/null | head -n100 | tr $'\n' ',' > "$temp" + local output=$(cat "$temp") + rm -f "$temp" + if [[ "$output" != "$expected" ]]; then + show_message "Unexpected PrimesDemo output:" + echo "$output" 1>&2 + return 1 + fi +} + + run_all() { ZEOLITE_PATH=$(do_zeolite --get-path | grep '^/') echo 1>&2 @@ -369,6 +396,7 @@ test_global_include test_example_hello test_example_parser + test_example_primes ) run_all "${ALL_TESTS[@]}" 1>&2 diff --git a/tests/filters.0rt b/tests/filters.0rt --- a/tests/filters.0rt +++ b/tests/filters.0rt @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 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. @@ -50,14 +50,16 @@ @value interface Type4 {} -@value interface Value<#x> { +concrete Value<#x> { #x requires Type1 #x requires Type2 #x allows Type3 #x allows Type4 } +define Value {} + testcase "implicit bound from reversing another filter" { error require compiler "#x.+bound" @@ -67,12 +69,14 @@ @value interface Type {} -@value interface Value<#x,#y> { +concrete Value<#x,#y> { #x requires Type #y requires #x } +define Value {} + testcase "defines filter is not an upper bound" { compiles } @@ -81,12 +85,14 @@ @value interface Type2 {} -@value interface Value<#x> { +concrete Value<#x> { #x defines Type1 #x allows Type2 } +define Value {} + testcase "defines filter is not a lower bound" { compiles } @@ -95,12 +101,14 @@ @value interface Type2 {} -@value interface Value<#x> { +concrete Value<#x> { #x defines Type1 #x requires Type2 } +define Value {} + testcase "function param bounded on both sides" { error require compiler "#x.+bound" @@ -115,4 +123,244 @@ #x requires Type1 #x allows Type2 () -> () +} + + +testcase "category-level requires not met in @type call" { + error + require "any.+Formatted" +} + +concrete Type<#x> { + #x requires Formatted + + @type call () -> () +} + +define Type { + call () {} + + @category call2 () -> () + call2 () { + \ Type.call() + } +} + + +testcase "category-level defines not met in @type call" { + error + require "any.+Equals" +} + +concrete Type<#x> { + #x defines Equals<#x> + + @type call () -> () +} + +define Type { + call () {} + + @category call2 () -> () + call2 () { + \ Type.call() + } +} + + +testcase "category-level allows not met in @type call" { + error + require "all.+Int" +} + +concrete Type<#x> { + #x allows Int + + @type call () -> () +} + +define Type { + call () {} + + @category call2 () -> () + call2 () { + \ Type.call() + } +} + + +testcase "category-level requires not met in initialization" { + error + require "any.+Formatted" +} + +concrete Type<#x> { + #x requires Formatted + + @category call () -> () +} + +define Type { + call () { + \ Type{ } + } +} + + +testcase "category-level defines not met in initialization" { + error + require "any.+Equals" +} + +concrete Type<#x> { + #x defines Equals<#x> + + @category call () -> () +} + +define Type { + call () { + \ Type{ } + } +} + + +testcase "category-level allows not met in initialization" { + error + require "all.+Int" +} + +concrete Type<#x> { + #x allows Int + + @category call () -> () +} + +define Type { + call () { + \ Type{ } + } +} + + +testcase "function-level requires not met in call" { + error + require "any.+Formatted" +} + +concrete Type { + @type call<#x> + #x requires Formatted + () -> () +} + +define Type { + call () {} + + @category call2 () -> () + call2 () { + \ Type.call() + } +} + + +testcase "function-level defines not met in call" { + error + require "any.+Equals" +} + +concrete Type { + @type call<#x> + #x defines Equals<#x> + () -> () +} + +define Type { + call () {} + + @category call2 () -> () + call2 () { + \ Type.call() + } +} + + +testcase "function-level allows not met in call" { + error + require "all.+Int" +} + +concrete Type { + @type call<#x> + #x allows Int + () -> () +} + +define Type { + call () {} + + @category call2 () -> () + call2 () { + \ Type.call() + } +} + + +testcase "category-level filters meet function-level filter requirements" { + compiles +} + +concrete Type1 { + @type call<#i,#j,#k> + #i requires Formatted + #j defines Equals<#j> + #k allows Int + () -> () +} + +define Type1 { + call () {} +} + +concrete Type2<#x,#y,#z> { + #x requires Formatted + #y defines Equals<#y> + #z allows Int + + @type call () -> () +} + +define Type2 { + call () { + \ Type1.call<#x,#y,#z>() + } +} + + +testcase "category-level filters are not checked during function-param substitution" { + error + require "Char.+Int" + exclude "String" +} + +concrete Type<|#x> { + #x requires String +} + +define Type {} + +concrete Test { + @type call<#x> + #x requires Int + (optional Type<#x>) -> () +} + +define Test { + call (_) {} + + @type call2 () -> () + call2 () { + \ call(empty) + \ call(empty) + } } diff --git a/tests/function-calls.0rt b/tests/function-calls.0rt --- a/tests/function-calls.0rt +++ b/tests/function-calls.0rt @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 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. @@ -404,9 +404,11 @@ \ Call.call>() } -@value interface Value<#x> { +concrete Value<#x> { #x defines Equals<#x> } + +define Value {} concrete Call { @type call<#x> () -> () diff --git a/tests/inference.0rt b/tests/inference.0rt --- a/tests/inference.0rt +++ b/tests/inference.0rt @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 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. @@ -328,4 +328,35 @@ define Test { get (_,_) {} +} + + +testcase "all/any as valid lower/upper bounds" { + compiles +} + +concrete Test { + @type call<#x,#y> (Convert<#x,#y>) -> (#x,#y) +} + +define Test { + call (_) { + fail("this allows faking the return") + } + + @value run () -> () + run () { + any x1, all y1 <- call(Convert.create()) + all x2, any y2 <- call(Convert.create()) + } +} + +concrete Convert<#x|#y> { + @type create () -> (#self) +} + +define Convert { + create () { + return #self{ } + } } diff --git a/tests/internal-params.0rt b/tests/internal-params.0rt deleted file mode 100644 --- a/tests/internal-params.0rt +++ /dev/null @@ -1,368 +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 "internal param not visible from @type" { - error - require "#x" -} - -concrete Value {} - -define Value { - types<#x> {} - - @type something () -> () - something () { - optional #x val <- empty - } -} - - -testcase "internal filter not applied in @type" { - compiles -} - -unittest test { - \ Value.something() -} - -concrete Value { - @type something<#x> () -> () -} - -define Value { - types<#x> { - #x defines LessThan<#x> - } - - something () {} -} - - -testcase "internal filter not applied in @category" { - compiles -} - -unittest test { - \ Value:something() -} - -concrete Value { - @category something<#x> () -> () -} - -define Value { - types<#x> { - #x defines LessThan<#x> - } - - something () {} -} - - -testcase "internal params" { - success -} - -unittest test { - \ Value.create() -} - -concrete Value { - @type create<#x,#y> - () -> (Value) -} - -define Value { - types<#x,#y> {} - - create () { - return Value{ types<#x,#y> } - } -} - -@value interface Type1 {} -@value interface Type2 {} - - -testcase "internal params with filters" { - compiles -} - -@value interface Get<|#x> { - get () -> (#x) -} - -@value interface Set<#x|> { - set (#x) -> () -} - -concrete Value { - @type create<#x,#y> - #x requires Get<#x> - #y allows Set<#y> - () -> (Value) -} - -define Value { - types<#x,#y> { - #x requires Get<#x> - #y allows Set<#y> - } - - create () { - return Value{ types<#x,#y> } - } -} - - -testcase "internal params missing filters" { - error - require "Get|Set" -} - -@value interface Get<|#x> { - get () -> (#x) -} - -@value interface Set<#x|> { - set (#x) -> () -} - -concrete Value { - @category create<#x,#y> - () -> (Value) -} - -define Value { - types<#x,#y> { - #x requires Get<#x> - #y allows Set<#y> - } - - create () { - return Value{ types<#x,#y> } - } -} - - -testcase "internal params with values" { - compiles -} - -concrete Value { - @category create<#x,#y> - () -> (Value) -} - -define Value { - types<#x,#y> {} - - @value Bool value - - create () { - return Value{ types<#x,#y>, false } - } -} - - -testcase "value depends on internal param" { - success -} - -unittest test { - \ Value.create(Type.create()) -} - -concrete Type<#y> { - @type create () -> (Type<#y>) -} - -define Type { - create () { - return Type<#y>{ } - } -} - -concrete Value { - @type create<#x> - (Type<#x>) -> (Value) -} - -define Value { - types<#z> {} - - @value Type<#z> value - - create (value) { - return Value{ types<#x>, value } - } -} - - -testcase "value mismatch with internal param" { - error - require "create" - require "Bool" - require "String" -} - -unittest test { - \ Value.create(Type.create()) -} - -concrete Type<#y> { - @type create () -> (Type<#y>) -} - -define Type { - create () { - return Type<#y>{ } - } -} - -concrete Value { - @type create<#x> - (Type<#x>) -> (Value) -} - -define Value { - types<#z> {} - - @value Type<#z> value - - create (value) { - return Value{ types<#x>, value } - } -} - - -testcase "internal param clash with external" { - error - require "#x" -} - -concrete Value<#x> {} - -define Value { - types<#x> {} -} - - -testcase "internal param clash with function" { - error - require "#x" -} - -concrete Value { - @value check<#x> () -> () -} - -define Value { - types<#x> {} -} - - -testcase "internal param clash with internal function" { - error - require "#x" -} - -concrete Value {} - -define Value { - types<#x> {} - - @value check<#x> () -> () - check () {} -} - - -testcase "internal param no clash with category" { - compiles -} - -concrete Value { - @category create<#x> () -> (Value) -} - -define Value { - types<#x> {} - - create () { - return Value { types<#x> } - } -} - - -testcase "reduce internal param success" { - success -} - -unittest test { - Value value <- Value.create() - if (!value.check("")) { - fail("Failed") - } -} - -concrete Value { - @type create<#x> () -> (Value) - @value check<#y> (#y) -> (Bool) -} - -define Value { - types<#x> {} - - create () { - return Value { types<#x> } - } - - check (y) { - return present(reduce<#y,#x>(y)) - } -} - - -testcase "reduce internal param fail" { - success -} - -unittest test { - Value value <- Value.create() - if (value.check(value)) { - fail("Failed") - } -} - -concrete Value { - @type create<#x> () -> (Value) - @value check<#y> (#y) -> (Bool) -} - -define Value { - types<#x> {} - - create () { - return Value { types<#x> } - } - - check (y) { - return present(reduce<#y,#x>(y)) - } -} diff --git a/tests/local-rules.0rt b/tests/local-rules.0rt --- a/tests/local-rules.0rt +++ b/tests/local-rules.0rt @@ -256,3 +256,173 @@ $Hidden[foo]$ Int foo <- 1 } + + +testcase "ReadOnly @category member" { + error + require "foo.+read-only" + exclude "bar" +} + +concrete Type {} + +define Type { + $ReadOnly[foo]$ + + @category Int foo <- 1 + @category Int bar <- 1 + + @value call () -> () + call () { + bar <- 2 + foo <- 2 + } +} + + +testcase "Hidden @category member" { + error + require "foo.+hidden" + exclude "bar" +} + +concrete Type {} + +define Type { + $Hidden[foo]$ + + @category Int foo <- 1 + @category Int bar <- 1 + + @value call () -> () + call () { + bar <- 2 + foo <- 2 + } +} + + +testcase "Bad name for Hidden @category member" { + error + require "foo.+does not exist" +} + +concrete Type {} + +define Type { + $Hidden[foo]$ + + @category Int bar <- 1 +} + + +testcase "Hidden @category member is visible during init" { + success +} + +unittest test { + \ Testing.checkEquals(Type:get(),2) +} + +concrete Type { + @category get () -> (Int) +} + +define Type { + $Hidden[foo]$ + $ReadOnly[bar]$ + + @category Int foo <- 1 + @category Int bar <- foo+1 + + get () { + return bar + } +} + + +testcase "ReadOnly @value member" { + error + require "foo.+read-only" + exclude "bar" +} + +concrete Type {} + +define Type { + $ReadOnly[foo]$ + + @value Int foo + @value Int bar + + @value call () -> () + call () { + bar <- 2 + foo <- 2 + } +} + + +testcase "Hidden @value member" { + error + require "foo.+hidden" + exclude "bar" +} + +concrete Type {} + +define Type { + $Hidden[foo]$ + + @value Int foo + @value Int bar + + @value call () -> () + call () { + bar <- 2 + foo <- 2 + } +} + + +testcase "Bad name for Hidden @value member" { + error + require "foo.+does not exist" +} + +concrete Type {} + +define Type { + $Hidden[foo]$ + + @value Int bar +} + + +testcase "ReadOnly @value member can be initialized" { + success +} + +unittest test { + \ Testing.checkEquals(Type.create().get(),1) +} + +concrete Type { + @type create () -> (Type) + @value get () -> (Int) + +} + +define Type { + $ReadOnly[foo]$ + + @value Int foo + + create () { + return Type{ 1 } + } + + get () { + return foo + } +} diff --git a/tests/member-init.0rt b/tests/member-init.0rt --- a/tests/member-init.0rt +++ b/tests/member-init.0rt @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 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. @@ -317,4 +317,53 @@ get () { return value } +} + + +testcase "@category members read-only during others' init" { + error + require "value1.+read-only" +} + +concrete Test {} + +define Test { + @category Int value1 <- 1 + @category Int value2 <- (value1 <- 2) +} + + +testcase "bad type in @category member" { + error + require "Foo not found" +} + +concrete Test {} + +define Test { + @category optional Foo value <- empty +} + + +testcase "bad type in @value member" { + error + require "Foo not found" +} + +concrete Test {} + +define Test { + @value Foo value +} + + +testcase "param disallowed in @category member" { + error + require "#x not found" +} + +concrete Test<#x> {} + +define Test { + @category optional #x value <- empty } diff --git a/tests/module-only4/common-source.cpp b/tests/module-only4/common-source.cpp --- a/tests/module-only4/common-source.cpp +++ b/tests/module-only4/common-source.cpp @@ -29,7 +29,7 @@ namespace ZEOLITE_PRIVATE_NAMESPACE { #endif // ZEOLITE_PRIVATE_NAMESPACE -S CreateValue_Type1(S parent, const ParamTuple& params, const ValueTuple& args); +S CreateValue_Type1(S parent, const ValueTuple& args); struct ExtCategory_Type1 : public Category_Type1 { }; @@ -39,14 +39,14 @@ ReturnTuple Call_create(const S& self, const ParamTuple& params, const ValueTuple& args) { TRACE_FUNCTION("Type1.create") - return ReturnTuple(CreateValue_Type1(CreateType_Type1(Params<0>::Type()), ParamTuple(), + return ReturnTuple(CreateValue_Type1(CreateType_Type1(Params<0>::Type()), TypeInstance::Call(GetType_Type2(Params<0>::Type()), Function_Type2_create, ParamTuple(), ArgTuple()))); } }; struct ExtValue_Type1 : public Value_Type1 { - inline ExtValue_Type1(S p, const ParamTuple& params, const ValueTuple& args) - : Value_Type1(p, params), value(args.At(0)) {} + inline ExtValue_Type1(S p, const ValueTuple& args) + : Value_Type1(p), value(args.At(0)) {} ReturnTuple Call_get(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { TRACE_FUNCTION("Type1.get") @@ -64,8 +64,8 @@ static const auto cached = S_get(new ExtType_Type1(CreateCategory_Type1(), Params<0>::Type())); return cached; } -S CreateValue_Type1(S parent, const ParamTuple& params, const ValueTuple& args) { - return S_get(new ExtValue_Type1(parent, params, args)); +S CreateValue_Type1(S parent, const ValueTuple& args) { + return S_get(new ExtValue_Type1(parent, args)); } #ifdef ZEOLITE_PRIVATE_NAMESPACE @@ -78,7 +78,7 @@ namespace ZEOLITE_PUBLIC_NAMESPACE { #endif // ZEOLITE_PUBLIC_NAMESPACE -S CreateValue_Type3(S parent, const ParamTuple& params, const ValueTuple& args); +S CreateValue_Type3(S parent, const ValueTuple& args); struct ExtCategory_Type3 : public Category_Type3 { }; @@ -88,14 +88,14 @@ ReturnTuple Call_create(const S& self, const ParamTuple& params, const ValueTuple& args) { TRACE_FUNCTION("Type3.create") - return ReturnTuple(CreateValue_Type3(CreateType_Type3(Params<0>::Type()), ParamTuple(), + return ReturnTuple(CreateValue_Type3(CreateType_Type3(Params<0>::Type()), TypeInstance::Call(GetType_Type2(Params<0>::Type()), Function_Type2_create, ParamTuple(), ArgTuple()))); } }; struct ExtValue_Type3 : public Value_Type3 { - inline ExtValue_Type3(S p, const ParamTuple& params, const ValueTuple& args) - : Value_Type3(p, params), value(args.At(0)) {} + inline ExtValue_Type3(S p, const ValueTuple& args) + : Value_Type3(p), value(args.At(0)) {} ReturnTuple Call_get(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { TRACE_FUNCTION("Type3.get") @@ -113,8 +113,8 @@ static const auto cached = S_get(new ExtType_Type3(CreateCategory_Type3(), Params<0>::Type())); return cached; } -S CreateValue_Type3(S parent, const ParamTuple& params, const ValueTuple& args) { - return S_get(new ExtValue_Type3(parent, params, args)); +S CreateValue_Type3(S parent, const ValueTuple& args) { + return S_get(new ExtValue_Type3(parent, args)); } #ifdef ZEOLITE_PUBLIC_NAMESPACE diff --git a/tests/reduce.0rt b/tests/reduce.0rt --- a/tests/reduce.0rt +++ b/tests/reduce.0rt @@ -670,30 +670,6 @@ } -testcase "bad instance in reduce param" { - error - require "Test" - require "define" - require "Equals" -} - -unittest test { - \ reduce,Formatted>(empty) -} - -@value interface Value<#x> { - #x defines Equals<#x> -} - -concrete Call { - @type call<#x> () -> () -} - -define Call { - call () {} -} - - testcase "reduce from interface" { success } diff --git a/tests/regressions.0rt b/tests/regressions.0rt --- a/tests/regressions.0rt +++ b/tests/regressions.0rt @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 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. diff --git a/tests/self-type.0rt b/tests/self-type.0rt --- a/tests/self-type.0rt +++ b/tests/self-type.0rt @@ -37,16 +37,10 @@ require "#self not found" } -concrete Type { - @type create () -> (#self) -} +concrete Type {} define Type { - @category #self value <- Type.create() - - create () { - return Type{ } - } + @category optional #self value <- empty } @@ -503,52 +497,25 @@ compiles } -@value interface Base<#x> { - refines Formatted +concrete Type<#x> { #x allows #self } -@value interface Type1 { - refines Base -} - -@value interface Type2 { - refines Base -} - -@value interface Type3 { - refines Type2 -} +define Type {} testcase "#self nested in param filter" { compiles } -@value interface Base<#x> { +concrete Type<#x> { #x requires Writer<#self> #x defines Equals<#self> } -@value interface Writer<#x|> { - write (#x) -> (#self) -} - -concrete Type { - refines Base - refines Writer - defines Equals -} - -define Type { - write (_) { - return self - } +define Type {} - equals (_,_) { - return true - } -} +@value interface Writer<#x|> {} testcase "#self nested in inheritance" { @@ -576,4 +543,44 @@ @type interface Creator<|#x> { create () -> (#x) +} + + +testcase "#self allowed in category param filters" { + compiles +} + +concrete Type1<#x> { + #x allows #self +} + +define Type1 {} + +concrete Type2<#x> { + #x requires #self +} + +define Type2 {} + + +testcase "#self allowed in covavariant position of function param filter" { + compiles +} + +@value interface Type { + call<#x> + #x allows #self + () -> () +} + + +testcase "#self disallowed in contravariant position of function param filter" { + error + require "#self.+contravariant" +} + +@value interface Type { + call<#x> + #x requires #self + () -> () } diff --git a/tests/templates/.zeolite-module b/tests/templates/.zeolite-module --- a/tests/templates/.zeolite-module +++ b/tests/templates/.zeolite-module @@ -5,5 +5,9 @@ source: "tests/templates/Extension_Templated.cpp" categories: [Templated] } + category_source { + source: "tests/templates/Extension_Templated2.cpp" + categories: [Templated2] + } ] mode: incremental {} diff --git a/tests/templates/README.md b/tests/templates/README.md --- a/tests/templates/README.md +++ b/tests/templates/README.md @@ -6,10 +6,10 @@ ```shell ZEOLITE_PATH=$(zeolite --get-path) -rm -f $ZEOLITE_PATH/tests/templates/Extension_Templated.cpp # Remove the old template. -zeolite -p $ZEOLITE_PATH --templates tests/templates # Create a new template. -zeolite -p $ZEOLITE_PATH -r tests/templates # Recompile. -zeolite -p $ZEOLITE_PATH -t tests/templates # Run the test. +rm -f $ZEOLITE_PATH/tests/templates/Extension_*.cpp # Remove the old templates. +zeolite -p $ZEOLITE_PATH --templates tests/templates # Create a new template. +zeolite -p $ZEOLITE_PATH -r tests/templates # Recompile. +zeolite -p $ZEOLITE_PATH -t tests/templates # Run the test. ``` The most important step above is to delete the *old* template first. diff --git a/tests/templates/private.0rp b/tests/templates/private.0rp new file mode 100644 --- /dev/null +++ b/tests/templates/private.0rp @@ -0,0 +1,23 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 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$ + +concrete Templated2 { + @type create () -> (Templated2) +} diff --git a/tests/templates/public.0rp b/tests/templates/public.0rp new file mode 100644 --- /dev/null +++ b/tests/templates/public.0rp @@ -0,0 +1,26 @@ +/* ----------------------------------------------------------------------------- +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 Templated<#x> { + @category create<#y> + #y requires Formatted + #y defines Equals<#y> + () -> (Templated<#y>) + + @value get () -> (#x) +} diff --git a/tests/templates/templates.0rp b/tests/templates/templates.0rp deleted file mode 100644 --- a/tests/templates/templates.0rp +++ /dev/null @@ -1,26 +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] - -concrete Templated<#x> { - @category create<#y> - #y requires Formatted - #y defines Equals<#y> - () -> (Templated<#y>) - - @value get () -> (#x) -} diff --git a/tests/templates/tests.0rt b/tests/templates/tests.0rt --- a/tests/templates/tests.0rt +++ b/tests/templates/tests.0rt @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 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. @@ -22,15 +22,15 @@ } unittest test { - \ Test.run() + \ Templated:create() } -define Test { - run () { - \ Templated:create() - } + +testcase "private template generated" { + crash + require "Templated2\.create is not implemented" } -concrete Test { - @type run () -> () +unittest test { + \ Templated2.create() } diff --git a/tests/tracing.0rt b/tests/tracing.0rt --- a/tests/tracing.0rt +++ b/tests/tracing.0rt @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 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. @@ -180,5 +180,31 @@ call () { $TraceCreation$ \ value.call() + } +} + + +testcase "correct function name used for non-merged function" { + crash + require "message" + require "Type\.call" + exclude "Base" +} + +unittest test { + \ Type.call() +} + +@type interface Base { + call () -> () +} + +concrete Type { + defines Base +} + +define Type { + call () { + fail("message") } } diff --git a/tests/traverse.0rt b/tests/traverse.0rt new file mode 100644 --- /dev/null +++ b/tests/traverse.0rt @@ -0,0 +1,300 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 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 "simple traverse tests" { + success +} + +unittest simpleSum { + Int total <- 0 + traverse (Counter.zeroIndexed(5) -> Int i) { + total <- total+i + } + \ Testing.checkEquals(total,10) +} + +unittest ignoreValue { + Int total <- 0 + traverse (Counter.zeroIndexed(5) -> _) { + total <- total+1 + } + \ Testing.checkEquals(total,5) +} + +unittest existingVariable { + Int total <- 0 + Int i <- 0 + traverse (Counter.zeroIndexed(5) -> i) { + total <- total+i + } + \ Testing.checkEquals(total,10) + \ Testing.checkEquals(i,4) +} + +unittest breakAtLimit { + Int total <- 0 + traverse (Counter.zeroIndexed(10) -> Int i) { + if (i >= 5) { + break + } + total <- total+i + } + \ Testing.checkEquals(total,10) +} + +unittest continueOnOdd { + Int total <- 0 + traverse (Counter.zeroIndexed(10) -> Int i) { + if (i%2 == 1) { + continue + } + total <- total+i + } + \ Testing.checkEquals(total,20) +} + +concrete Counter { + refines Order + + @type zeroIndexed (Int) -> (optional Counter) +} + +define Counter { + @value Int current + @value Int max + + zeroIndexed (max) { + if (max < 1) { + return empty + } else { + return Counter{ 0, max } + } + } + + next () { + if (current+1 < max) { + current <- current+1 + return self + } else { + return empty + } + } + + get () { + return current + } +} + + +testcase "bad traverse container" { + error + require "Int.+Order" +} + +unittest test { + traverse (0 -> _) {} +} + + +testcase "bad traverse variable" { + error + require "String.+Int" +} + +concrete Empty<|#x> { + refines Order<#x> + + @category new<#x> () -> (optional Empty<#x>) +} + +define Empty { + new () { + return empty + } + + next () { + fail("next() not implemented") + } + + get () { + fail("get() not implemented") + } +} + +unittest test { + traverse (Empty:new() -> Int i) {} +} + + +// #auto is used internally when compiling traverse. +testcase "no clash when #auto is in category" { + success +} + +unittest test { + \ Test.run() +} + +concrete Test<#auto> { + @type run () -> () +} + +define Test { + run () { + Int total <- 0 + traverse (Counter.new() -> Int i) { + total <- total+i + } + \ Testing.checkEquals(total,10) + } +} + +concrete Counter { + refines Order + + @type new () -> (Counter) +} + +define Counter { + @value Int current + + new () { + return Counter{ 0 } + } + + next () { + if (current+1 < 5) { + current <- current+1 + return self + } else { + return empty + } + } + + get () { + return current + } +} + + +// #auto is used internally when compiling traverse. +testcase "no clash when #auto is in function call" { + success +} + +unittest test { + \ Test.run() +} + +concrete Test { + @type run<#auto> () -> () +} + +define Test { + run () { + Int total <- 0 + traverse (Counter.new() -> Int i) { + total <- total+i + } + \ Testing.checkEquals(total,10) + } +} + +concrete Counter { + refines Order + + @type new () -> (Counter) +} + +define Counter { + @value Int current + + new () { + return Counter{ 0 } + } + + next () { + if (current+1 < 5) { + current <- current+1 + return self + } else { + return empty + } + } + + get () { + return current + } +} + + +// #auto is used internally when compiling traverse. +testcase "no clash when #auto also the inferred type" { + success +} + +unittest test { + \ Testing.checkEquals(Test.run("message"),"message") +} + +concrete Test { + @type run<#auto> (#auto) -> (#auto) +} + +define Test { + run (x) (i) { + i <- x + Int total <- 0 + traverse (Repeat:times(x,10) -> i) { + total <- total+1 + } + \ Testing.checkEquals(total,10) + } +} + +concrete Repeat<|#x> { + refines Order<#x> + + @category times<#y> (#y,Int) -> (optional Repeat<#y>) +} + +define Repeat { + @value #x value + @value Int count + + times (value,count) { + if (count < 1) { + return empty + } else { + return Repeat<#y>{ value, count } + } + } + + next () { + if (count > 1) { + count <- count-1 + return self + } else { + return empty + } + } + + get () { + return value + } +} diff --git a/tests/typename.0rt b/tests/typename.0rt --- a/tests/typename.0rt +++ b/tests/typename.0rt @@ -110,23 +110,3 @@ fail(name) } } - - -testcase "bad instance in typename param" { - error - require "Test" - require "define" - require "Equals" -} - -unittest test { - \ typename>() -} - -@value interface Value<#x> { - #x defines Equals<#x> -} - -concrete Test {} - -define Test {} 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.15.0.0 +version: 0.16.0.0 synopsis: Zeolite is a statically-typed, general-purpose programming language. description: @@ -80,6 +80,10 @@ example/parser/*.0rt, example/parser/*.0rx, example/parser/*.txt, + example/primes/.zeolite-module, + example/primes/README.md, + example/primes/*.0rp, + example/primes/*.0rx, lib/container/README.md, lib/container/.zeolite-module, lib/container/*.0rp,