diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,52 @@ # Revision history for zeolite-lang +## 0.6.0.0 -- 2020-05-14 + +### Compiler CLI + +* **[behavior]** Improves error messages for type mismatches and return-count + mismatches. + +* **[behavior]** Improves the efficiency of loading metadata for dependencies. + +* **[breaking]** Fixes module-staleness check when running tests (`-t`). + +* **[breaking]** Prevents binaries from being created from main categories that + are defined in `$TestsOnly$` sources. (This was the original intention, but it + was missed the first time around.) + +### Language + +* **[new]** Allows `@category` members in `concrete` categories to refer to each + other during initialization. + +* **[new]** Adds the `$ExprLookup[`*`MACRO_NAME`*`]$` pragma, which allows the + user to define expression substitutions in `.zeolite-module`. + +* **[new]** Adds the `$NoTrace$` pragma, which skips generating stack-trace + information for specific functions. This is useful for deeply-recursive + functions whose full trace would not be useful. + +* **[new]** Adds the `$TraceCreation$` pragma, which appends a trace for the + creation of a value when there is a crash in one of its functions. This is + useful when the crash stems from value initialization. + +* **[fix]** Fixes parsing of the `'"'` `Char`-literal. + +### Libraries + +* **[new]** Adds the `ErrorOr<#x>` category to `lib/util`. This allows functions + to return either the expected type or an error message. + +* **[new]** Adds the `Void` category to `lib/util`. This can be used to ignore + type parameters when a value still needs to be instantiated. + +* **[new]** Adds the `readAll` function to `TextReader` (in `lib/util`) to + support reading an entire file at once. + +* **[breaking]** Adds crashes when attempting to read `RawFileReader` or write + `RawFileWriter` if there is a preexisting file error. + ## 0.5.0.0 -- 2020-05-12 * **[new]** Adds compiler support for pragmas, which will allow compiler diff --git a/base/logging.cpp b/base/logging.cpp --- a/base/logging.cpp +++ b/base/logging.cpp @@ -40,11 +40,21 @@ std::cerr << " '" << condition_ << "'"; } std::cerr << ": " << output_.str() << std::endl; - for (const auto& trace : TraceContext::GetTrace()) { + const TraceList call_trace = TraceContext::GetTrace(); + for (const auto& trace : call_trace) { if (!trace.empty()) { std::cerr << " " << trace << std::endl; } } + const TraceList creation_trace = TraceCreation::GetTrace(); + if (!creation_trace.empty()) { + std::cerr << TraceCreation::GetType() << " value originally created at:" << std::endl; + for (const auto& trace : creation_trace) { + if (!trace.empty()) { + std::cerr << " " << trace << std::endl; + } + } + } std::raise(signal_); } } @@ -92,8 +102,8 @@ } -std::list TraceContext::GetTrace() { - std::list trace; +TraceList TraceContext::GetTrace() { + TraceList trace; const TraceContext* current = GetCurrent(); while (current) { current->AppendTrace(trace); @@ -107,7 +117,7 @@ at_ = at; } -void SourceContext::AppendTrace(std::list& trace) const { +void SourceContext::AppendTrace(TraceList& trace) const { std::ostringstream output; if (at_ == nullptr || at_[0] == 0x00) { output << "From " << name_; @@ -126,7 +136,7 @@ at_ = at; } -void CleanupContext::AppendTrace(std::list& trace) const { +void CleanupContext::AppendTrace(TraceList& trace) const { std::ostringstream output; if (at_ == nullptr || at_[0] == 0x00) { output << "In cleanup block"; diff --git a/base/logging.hpp b/base/logging.hpp --- a/base/logging.hpp +++ b/base/logging.hpp @@ -73,6 +73,12 @@ #define PRED_CONTEXT_POINT(point) \ TraceContext::SetContext(point), + #define CAPTURE_CREATION \ + CreationTrace creation_context_; + + #define TRACE_CREATION \ + TraceCreation trace_creation(TypeInstance::TypeName(parent), creation_context_); + #else #define TRACE_FUNCTION(name) @@ -83,11 +89,19 @@ #define PRED_CONTEXT_POINT(point) + #define CAPTURE_CREATION + + #define TRACE_CREATION + #endif + +using TraceList = std::list; + + class TraceContext : public capture_thread::ThreadCapture { public: - static std::list GetTrace(); + static TraceList GetTrace(); template static inline void SetContext(const char(&at)[S]) { @@ -101,7 +115,7 @@ private: virtual void SetLocal(const char*) = 0; - virtual void AppendTrace(std::list& trace) const = 0; + virtual void AppendTrace(TraceList& trace) const = 0; virtual const TraceContext* GetNext() const = 0; }; @@ -113,7 +127,7 @@ private: void SetLocal(const char*) final; - void AppendTrace(std::list& trace) const final; + void AppendTrace(TraceList& trace) const final; const TraceContext* GetNext() const final; const char* at_; @@ -128,7 +142,7 @@ private: void SetLocal(const char*) final; - void AppendTrace(std::list& trace) const final; + void AppendTrace(TraceList& trace) const final; const TraceContext* GetNext() const final; const char* at_; @@ -156,6 +170,46 @@ const std::vector& GetArgs() const final; const std::vector argv_; + const ScopedCapture capture_to_; +}; + +class CreationTrace { + public: + inline CreationTrace() : trace_(TraceContext::GetTrace()) {} + + inline const TraceList& GetTrace() const { + return trace_; + } + + private: + 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) {} + + static inline std::string GetType() { + if (GetCurrent()) { + return GetCurrent()->type_; + } else { + return std::string(); + } + } + + static inline TraceList GetTrace() { + if (GetCurrent()) { + return GetCurrent()->trace_.GetTrace(); + } else { + return TraceList(); + } + } + + private: + + const std::string type_; + const CreationTrace& trace_; const ScopedCapture capture_to_; }; diff --git a/example/parser/.zeolite-module b/example/parser/.zeolite-module new file mode 100644 --- /dev/null +++ b/example/parser/.zeolite-module @@ -0,0 +1,9 @@ +root: "../.." +path: "example/parser" +public_deps: [ + "lib/util" +] +private_deps: [ + "lib/file" +] +mode: incremental {} diff --git a/example/parser/README.md b/example/parser/README.md new file mode 100644 --- /dev/null +++ b/example/parser/README.md @@ -0,0 +1,81 @@ +# Zeolite Parser Example + +*Also see +[a highlighted version of the example code](https://ta0kira.github.io/zeolite/example/parser).* + +This example demonstrates parsing text using a parser-combinator approach +inspired by [`parsec`][parsec]. (The Haskell library that the `zeolite` compiler +uses to parse source and config files.) + +## Notes + +This example highlights several distinguishing features of the +[Zeolite language][zeolite]: + +- **Encapsulation.** Data encapsulation is mandatory in Zeolite. This forces the + code author to think about usage patterns before data representation. + +- **Factory Functions.** There is no "default construction" in Zeolite; the code + author must explicitly expose factory functions if needed. In this example, + most of the factory functions return an interface, rather than the actual + `concrete` type being constructed. + +- **Internal Inheritance.** `ParseState` inherits `ParseContext` internally + (see `parser.0rp` and `parser.0rx`), which allows `ParseState` to + conditionally expose the `ParseContext` interface to other functions. + +- **Function Merging.** `ParseState` and `ParseContext` declare some of the same + functions in `parser.0rp`. When `ParseState` inherits `ParseContext` + internally in `parser.0rx`, functions with the same names are merged by the + compiler. This allows `ParseState` to expose a subset of `ParseContext` + without needing a superfluous interface with the shared functions. + +- **Parameter Variance.** Several categories used in this example (e.g., + `ParseState` and `ParseContext`) have a *covariant* parameter, which allows + their parameters to be converted to other types. Specifically: + + - Any `ParseContext<#x>` can be converted to `ParseContext` when calling + `Parser.run`. (In C++ this would require a `template` and in Java it would + require using ``.) + + - The `ParseState` returned from `ParseContext.setBrokenInput` can be + converted to all other `ParseState<#x>`. (In C++ or Java this would require + the caller to explicitly pass a type parameter to `setBrokenInput`.) + +- **Multiple Returns.** Many of the functions in this example return more than + one value to the caller. (In C++ and Java this would require a data structure + for grouping objects together.) + +- **Test Sources.** The `parser-test.0rt` source file contains a `testcase` that + the compiler itself can execute. + +- **Expression Pragmas.** `parser-test.0rt` uses the `$ExprLookup[MODULE_PATH]$` + pragma to get the absolute path to its own module in order to locate a data + file. This might otherwise require hard-coding a path or relying on the tests + being executed from the module path. + +- **Module Config.** The `.zeolite-module` file contains the build configuration + for this example. This means that building and running the example does not + require special instructions, scripting, or `Makefile`s. + +## Running + +(Included with compiler package starting with version `0.6.0.0`.) + +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/parser + +# Run the unit tests. +zeolite -p "$ZEOLITE_PATH" -t example/parser +``` + +(There is currently no binary target in this example.) + +[parsec]: https://hackage.haskell.org/package/parsec +[zeolite]: https://github.com/ta0kira/zeolite diff --git a/example/parser/parse-text.0rp b/example/parser/parse-text.0rp new file mode 100644 --- /dev/null +++ b/example/parser/parse-text.0rp @@ -0,0 +1,27 @@ +/* Parses a fixed string. + */ +concrete StringParser { + @type create (String) -> (Parser) +} + +/* Parses a string containing a limited set of characters. + */ +concrete SequenceOfParser { + @type create (String, Int /*min*/, Int /*max*/) -> (Parser) +} + +/* Parses a fixed character. + */ +concrete CharParser { + @type create (Char) -> (Parser) +} + +/* Parser combinators. + */ +concrete Parse { + @type const<#x> (#x) -> (Parser<#x>) + @type try<#x> (Parser<#x>) -> (Parser<#x>) + @type or<#x> (Parser<#x>,Parser<#x>) -> (Parser<#x>) + @type left<#x> (Parser<#x>,Parser) -> (Parser<#x>) + @type right<#x> (Parser,Parser<#x>) -> (Parser<#x>) +} diff --git a/example/parser/parse-text.0rx b/example/parser/parse-text.0rx new file mode 100644 --- /dev/null +++ b/example/parser/parse-text.0rx @@ -0,0 +1,254 @@ +define StringParser { + refines Parser + + @value String match + + run (contextOld) { + if (contextOld.hasAnyError()) { + return contextOld.convertError() + } + String message <- "Failed to match \"" + match + "\" at " + contextOld.getPosition() + ParseContext context <- contextOld + scoped { + Int index <- 0 + } in while (index < match.readSize()) { + if (context.atEof() || context.current() != match.readPosition(index)) { + if (index > 0) { + // Partial match => set error context. + return context.setBrokenInput(message) + } else { + return context.setValue(ErrorOr$$error(message)) + } + } + } update { + index <- index+1 + context <- context.advance() + } + return context.setValue(ErrorOr$$value(match)) + } + + create (match) { + return StringParser{ match } + } +} + +define SequenceOfParser { + refines Parser + + @value String matches + @value Int min + @value Int max + + run (contextOld) { + if (contextOld.hasAnyError()) { + return contextOld.convertError() + } + String message <- "Failed to match [" + matches + "]{" + + min.formatted() + "," + max.formatted() + "} at " + + contextOld.getPosition() + ParseContext context <- contextOld + Builder builder <- String$builder() + Int count <- 0 + while (!context.atEof() && (max == 0 || count < max)) { + Bool found <- false + scoped { + Int index <- 0 + } in while (index < matches.readSize()) { + if (context.current() == matches.readPosition(index)) { + \ builder.append(matches.readPosition(index).formatted()) + found <- true + break + } + } update { + index <- index+1 + } + if (!found) { + break + } + } update { + count <- count+1 + context <- context.advance() + } + if (count >= min) { + return context.setValue(ErrorOr$$value(builder.build())) + } elif (count > 0) { + // Partial match => set error context. + return context.setBrokenInput(message) + } else { + return context.setValue(ErrorOr$$error(message)) + } + } + + create (matches,min,max) { + return SequenceOfParser{ matches, min, max } + } +} + +define CharParser { + refines Parser + + @value Char match + + run (contextOld) { + if (contextOld.hasAnyError()) { + return contextOld.convertError() + } + if (contextOld.atEof() || contextOld.current() != match) { + String message <- "Failed to match '" + match.formatted() + "' at " + contextOld.getPosition() + return contextOld.setValue(ErrorOr$$error(message)) + } else { + return contextOld.advance().setValue(ErrorOr$$value(match)) + } + } + + create (match) { + return CharParser{ match } + } +} + +concrete ConstParser<#x> { + @type create (#x) -> (Parser<#x>) +} + +define ConstParser { + refines Parser<#x> + + @value #x value + + run (contextOld) { + return contextOld.setValue<#x>(ErrorOr$$value<#x>(value)) + } + + create (value) { + return ConstParser<#x>{ value } + } +} + +concrete TryParser<#x> { + @type create (Parser<#x>) -> (Parser<#x>) +} + +define TryParser { + refines Parser<#x> + + @value Parser<#x> parser + + run (contextOld) { + if (contextOld.hasAnyError()) { + return contextOld.convertError<#x>() + } + ParseContext<#x> context <- contextOld.run<#x>(parser) + if (context.hasAnyError()) { + return contextOld.setValue<#x>(context.getValue().convertError()) + } else { + return context.toState() + } + } + + create (parser) { + return TryParser<#x>{ parser } + } +} + +concrete OrParser<#x> { + @type create (Parser<#x>,Parser<#x>) -> (Parser<#x>) +} + +define OrParser { + refines Parser<#x> + + @value Parser<#x> parser1 + @value Parser<#x> parser2 + + run (contextOld) { + if (contextOld.hasAnyError()) { + return contextOld.convertError<#x>() + } + ParseContext<#x> context <- contextOld.run<#x>(parser1) + if (context.hasAnyError() && !context.hasBrokenInput()) { + return contextOld.run<#x>(parser2).toState() + } else { + return context.toState() + } + } + + create (parser1,parser2) { + return OrParser<#x>{ parser1, parser2 } + } +} + +concrete LeftParser<#x> { + @type create (Parser<#x>,Parser) -> (Parser<#x>) +} + +define LeftParser { + refines Parser<#x> + + @value Parser<#x> parser1 + @value Parser parser2 + + run (contextOld) { + if (contextOld.hasAnyError()) { + return contextOld.convertError<#x>() + } + ParseContext<#x> context <- contextOld.run<#x>(parser1) + if (!context.hasAnyError()) { + return context.run(parser2).setValue<#x>(context.getValue()) + } else { + return context.toState() + } + } + + create (parser1,parser2) { + return LeftParser<#x>{ parser1, parser2 } + } +} + +concrete RightParser<#x> { + @type create (Parser,Parser<#x>) -> (Parser<#x>) +} + +define RightParser { + refines Parser<#x> + + @value Parser parser1 + @value Parser<#x> parser2 + + run (contextOld) { + if (contextOld.hasAnyError()) { + return contextOld.convertError<#x>() + } + ParseContext context <- contextOld.run(parser1) + if (!context.hasAnyError()) { + return context.run<#x>(parser2).toState() + } else { + return context.convertError<#x>() + } + } + + create (parser1,parser2) { + return RightParser<#x>{ parser1, parser2 } + } +} + +define Parse { + const (value) { + return ConstParser<#x>$create(value) + } + + try (parser) { + return TryParser<#x>$create(parser) + } + + or (parser1,parser2) { + return OrParser<#x>$create(parser1,parser2) + } + + left (parser1,parser2) { + return LeftParser<#x>$create(parser1,parser2) + } + + right (parser1,parser2) { + return RightParser<#x>$create(parser1,parser2) + } +} diff --git a/example/parser/parser-test.0rt b/example/parser/parser-test.0rt new file mode 100644 --- /dev/null +++ b/example/parser/parser-test.0rt @@ -0,0 +1,34 @@ +testcase "parse data from a file" { + success Test$execute() +} + +concrete Test { + @type execute () -> () +} + +define Test { + execute () { + TestData data <- TestData$parseFrom(loadTestData()).getValue() + + if (data.getName() != "example data") { + fail(data.getName()) + } + + if (data.getDescription() != "THIS_IS_A_TOKEN") { + fail(data.getDescription()) + } + + if (data.getBoolean() != false) { + fail(data.getBoolean()) + } + } + + @type loadTestData () -> (String) + loadTestData () { + scoped { + RawFileReader reader <- RawFileReader$open($ExprLookup[MODULE_PATH]$ + "/test-data.txt") + } cleanup { + \ reader.freeResource() + } in return TextReader$readAll(reader) + } +} diff --git a/example/parser/parser.0rp b/example/parser/parser.0rp new file mode 100644 --- /dev/null +++ b/example/parser/parser.0rp @@ -0,0 +1,51 @@ +/* Manages state for parsing operations outside of a Parser. + * + * The state is immutable; all update operations return a new state. + * + * Since #x is covariant, any ParseState can convert to ParseState, and + * ParseState can convert to all other ParseState. + */ +concrete ParseState<|#x> { + @category new (String) -> (ParseState) + + @value run<#y> (Parser<#y>) -> (ParseState<#y>) + @value runAndGet<#y> (Parser<#y>) -> (ParseState,ErrorOr<#y>) + + @value atEof () -> (Bool) + @value hasAnyError () -> (Bool) + @value getError () -> (Formatted) +} + +/* A self-contained parser operation. + * + * Since #x is covariant, any Parser can convert to Parser, and Parser + * can convert to all other Parser. + */ +@value interface Parser<|#x> { + run (ParseContext) -> (ParseState<#x>) +} + +/* Parser context available when running a Parser. + * + * Since #x is covariant, any ParseContext can convert to ParseContext, and + * ParseContext can convert to all other ParseContext. + */ +@value interface ParseContext<|#x> { + run<#y> (Parser<#y>) -> (ParseContext<#y>) + runAndGet<#y> (Parser<#y>) -> (ParseContext,ErrorOr<#y>) + + convertError<#y> () -> (ParseState<#y>) + getValue () -> (ErrorOr<#x>) + setValue<#y> (ErrorOr<#y>) -> (ParseState<#y>) + setBrokenInput (Formatted) -> (ParseState) + toState () -> (ParseState<#x>) + + getPosition () -> (String) + + atEof () -> (Bool) + hasAnyError () -> (Bool) + hasBrokenInput () -> (Bool) + + current () -> (Char) + advance () -> (ParseContext<#x>) +} diff --git a/example/parser/parser.0rx b/example/parser/parser.0rx new file mode 100644 --- /dev/null +++ b/example/parser/parser.0rx @@ -0,0 +1,120 @@ +define ParseState { + // This internal inheritance takes advantage of function merging. + // + // Notice that several functions (e.g., run, hasAnyError) appear to be + // declared separately in ParseState and ParseContext in parser.0rp. Since the + // function types are compatible, the compiler automatically merges them. This + // allows ParseState to expose a subset of ParseContext without needing a + // superfluous interface that both categories refine. + refines ParseContext<#x> + + @value String data + @value Int index + @value Int line + @value Int char + @value ErrorOr<#x> value + @value optional Formatted error + + new (data) { + return ParseState{ data, 0, 0, 0, ErrorOr$$value(Void$void()), empty } + } + + run (parser) { + return parser.run(self) + } + + runAndGet (parser) { + ParseState<#y> context <- parser.run(self) + return context, context.getValue() + } + + convertError () { + return ParseState<#y>{ data, index, line, char, ErrorOr$$error(getError()), error } + } + + getValue () { + if (present(error)) { + return ErrorOr$$error(require(error)) + } else { + return value + } + } + + setValue (value2) { + if (hasBrokenInput()) { + return convertError<#y>() + } else { + return ParseState<#y>{ data, index, line, char, value2, error } + } + } + + setBrokenInput (message) { + return ParseState{ data, index, line, char, ErrorOr$$error(message), message } + } + + toState () { + return self + } + + getPosition () { + return String$builder() + .append("(") + .append(line.formatted()) + .append(",") + .append(char.formatted()) + .append(")") + .build() + } + + atEof () { + return index >= data.readSize() + } + + hasAnyError () { + return present(error) || value.isError() + } + + hasBrokenInput () { + return present(error) + } + + current () { + \ sanityCheck() + return data.readPosition(index) + } + + advance () { + \ sanityCheck() + if (data.readPosition(index) == '\n') { + return ParseState<#x>{ data, index+1, line+1, 0, value, error } + } else { + return ParseState<#x>{ data, index+1, line, char+1, value, error } + } + } + + getError () { + if (present(error)) { + return require(error) + } else { + return value.getError() + } + } + + @value sanityCheck () -> () + sanityCheck () { + if (hasBrokenInput()) { + \ LazyStream$new() + .append("Error at ") + .append(getPosition()) + .append(": ") + .append(getError()) + .writeTo(SimpleOutput$error()) + } + if (atEof()) { + \ LazyStream$new() + .append("Reached end of input at ") + .append(getPosition()) + .writeTo(SimpleOutput$error()) + } + } +} diff --git a/example/parser/test-data.0rp b/example/parser/test-data.0rp new file mode 100644 --- /dev/null +++ b/example/parser/test-data.0rp @@ -0,0 +1,11 @@ +$TestsOnly$ + +/* Parses the test-data.txt file using a one-off format. + */ +concrete TestData { + @type parseFrom (String) -> (ErrorOr) + + @value getName () -> (String) + @value getDescription () -> (String) + @value getBoolean () -> (Bool) +} diff --git a/example/parser/test-data.0rx b/example/parser/test-data.0rx new file mode 100644 --- /dev/null +++ b/example/parser/test-data.0rx @@ -0,0 +1,85 @@ +$TestsOnly$ + +define TestData { + @category Parser whitespace <- SequenceOfParser$create(" \n\t",1,0) + + @category Parser sentence <- SentenceParser$create() + @category Parser token <- SequenceOfParser$create("ABCDEFGHIJKLMNOPQRSTUVWXYZ_",1,0) + @category Parser sentenceOrToken <- sentence `Parse$or` token `Parse$left` whitespace + + @category Parser acronym <- StringParser$create("acronym") `Parse$right` Parse$const(true) + @category Parser aardvark <- StringParser$create("aardvark") `Parse$right` Parse$const(false) + @category Parser acronymOrAardvark <- `Parse$try` acronym `Parse$or` aardvark `Parse$left` whitespace + + @category Parser fileStart <- StringParser$create("file_start") `Parse$left` whitespace + @category Parser fileEnd <- StringParser$create("file_end") `Parse$left` whitespace + @category Parser nameTag <- StringParser$create("name:") `Parse$left` whitespace + @category Parser descriptionTag <- StringParser$create("description:") `Parse$left` whitespace + @category Parser aWordTag <- StringParser$create("a_word:") `Parse$left` whitespace + + @value String name + @value String description + @value Bool boolean + + parseFrom (data) { + ParseState state <- ParseState$$new(data) + state <- state.run(fileStart) + state <- state.run(nameTag) + state, ErrorOr name <- state.runAndGet(sentenceOrToken) + state <- state.run(descriptionTag) + state, ErrorOr description <- state.runAndGet(sentenceOrToken) + state <- state.run(aWordTag) + state, ErrorOr boolean <- state.runAndGet(acronymOrAardvark) + state <- state.run(fileEnd) + + if (state.hasAnyError()) { + return ErrorOr$$error(state.getError()) + } elif (!state.atEof()) { + return ErrorOr$$error("Parsing did not consume all of the data") + } else { + return ErrorOr$$value(TestData{ name.getValue(), + description.getValue(), + boolean.getValue() }) + } + } + + getName () { + return name + } + + getDescription () { + return description + } + + getBoolean () { + return boolean + } +} + +concrete SentenceParser { + @type create () -> (Parser) +} + +define SentenceParser { + refines Parser + + @category String sentenceChars <- "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + + "abcdefghijklmnopqrstuvwxyz" + + "., !?-" + @category Parser string <- SequenceOfParser$create(sentenceChars,0,0) + + run (contextOld) { + if (contextOld.hasAnyError()) { + return contextOld.convertError() + } + ParseContext context <- contextOld + context <- context.run(CharParser$create('"')) + context, ErrorOr text <- context.runAndGet(string) + context <- context.run(CharParser$create('"')) + return context.setValue(text) + } + + create () { + return SentenceParser{ } + } +} diff --git a/example/parser/test-data.txt b/example/parser/test-data.txt new file mode 100644 --- /dev/null +++ b/example/parser/test-data.txt @@ -0,0 +1,5 @@ +file_start + name: "example data" + description: THIS_IS_A_TOKEN + a_word: aardvark +file_end diff --git a/example/regex/README.md b/example/regex/README.md deleted file mode 100644 --- a/example/regex/README.md +++ /dev/null @@ -1,20 +0,0 @@ -# Zeolite Regex Example - -*Also see -[a highlighted version of the example code](https://ta0kira.github.io/zeolite/example/regex).* - -To run the example: - -```shell -# This is just to locate the example code. Not for normal use! -ZEOLITE_PATH=$(zeolite --get-path) - -# Compile the example. -zeolite -p "$ZEOLITE_PATH" -i lib/util -m RegexDemo example/regex - -# Run the unit tests. -zeolite -p "$ZEOLITE_PATH" -t example/regex - -# Execute the compiled binary. -$ZEOLITE_PATH/example/regex/RegexDemo -``` diff --git a/example/regex/char-regex.0rp b/example/regex/char-regex.0rp deleted file mode 100644 --- a/example/regex/char-regex.0rp +++ /dev/null @@ -1,4 +0,0 @@ -concrete CharRegex { - @type parse (String) -> (optional MatcherTemplate) - @type match (MatcherTemplate,String) -> (Bool) -} diff --git a/example/regex/char-regex.0rx b/example/regex/char-regex.0rx deleted file mode 100644 --- a/example/regex/char-regex.0rx +++ /dev/null @@ -1,199 +0,0 @@ -define CharRegex { - parse (pattern) (matcher) { - ReadIterator p <- ReadIterator$$fromReadPosition(pattern) - // TODO: Needs error handling. - _, matcher <- parseExpression(p) - } - - match (template,data) { - ReadIterator p <- ReadIterator$$fromReadPosition(data) - Matcher matcher <- template.newMatcher() - while (!p.pastForwardEnd()) { - MatchState state <- matcher.tryNextMatch(p.readCurrent()) - if (state `MatchState$equals` MatchState$matchFail()) { - break - } - p <- p.forward() - if (state `MatchState$equals` MatchState$matchComplete()) { - break - } - } - return p.pastForwardEnd() && matcher.matchSatisfied() - } - - @type parseSequence (ReadIterator) -> - (ReadIterator,optional ReadSequence>) - parseSequence (p) { - if (p.pastForwardEnd()) { - return p, empty - } - ReadIterator p2, optional MatcherTemplate matcher <- parseNonSequence(p) - if (!p2.pastForwardEnd() && (p2.readCurrent() == '|' || p2.readCurrent() == ')')) { - // Requires choice matching or the end of a subexpression. - if (present(matcher)) { - return p2, LinkedNode>$create(require(matcher),empty) - } else { - // TODO: Disregards errors from parseNonSequence. - return p2, LinkedNode>$create(MatchEmpty$create(),empty) - } - } if (!present(matcher)) { - return p2, empty - } else { - p2, optional ReadSequence> sequence <- parseSequence(p2) - return p2, LinkedNode>$create(require(matcher),sequence) - } - } - - @type parseNonSequence (ReadIterator) -> - (ReadIterator,optional MatcherTemplate) - parseNonSequence (p) (p2,matcher) { - p2 <- p - matcher <- empty - while (!p2.pastForwardEnd()) { - Char c <- p2.readCurrent() - if (c == '|' || c == ')') { - // Requires choice matching or the end of a subexpression. - return _ - } elif (c == '*') { - // TODO: Needs error handling. - return p2.forward(), - MatchBranches$create(BranchRepeat$createZeroPlus(require(matcher))) - } elif (c == '+') { - // TODO: Needs error handling. - return p2.forward(), - MatchBranches$create(BranchRepeat$createOnePlus(require(matcher))) - } elif (c == '{') { - p2, Int min, Int max <- parseRange(p2.forward()) - if (p2.pastForwardEnd() || p2.readCurrent() != '}') { - // TODO: Needs error handling. - fail("missing }") - } - return p2.forward(), - MatchBranches$create(BranchRepeat$createRange(min,max,require(matcher))) - } elif (present(matcher)) { - return _ - } elif (c == '[') { - p2, matcher <- parseCharChoices(p2.forward()) - if (p2.pastForwardEnd() || p2.readCurrent() != ']') { - // TODO: Needs error handling. - fail("missing ]") - } - p2 <- p2.forward() - } elif (c == '(') { - p2, matcher <- parseExpression(p2.forward()) - if (p2.pastForwardEnd() || p2.readCurrent() != ')') { - // TODO: Needs error handling. - fail("missing )") - } - p2 <- p2.forward() - } else { - p2, matcher <- parseSingleChar(p2) - } - } - } - - @type parseRange (ReadIterator) -> (ReadIterator,Int,Int) - parseRange (p) (p2,min,max) { - max <- 0 - p2, min <- parseCount(p) - if (p2.pastForwardEnd() || p2.readCurrent() != ',') { - max <- min - } else { - p2, max <- parseCount(p2.forward()) - } - } - - @type parseCount (ReadIterator) -> (ReadIterator,Int) - parseCount (p) (p2,count) { - // TODO: Needs error handling. - count <- 0 - p2 <- p - while (!p2.pastForwardEnd()) { - Char c <- p2.readCurrent() - if (c >= '0' && c <= '9') { - count <- 10*count + (c - '0') - } else { - break - } - } update { - p2 <- p2.forward() - } - } - - @type parseExpression (ReadIterator) -> - (ReadIterator,optional MatcherTemplate) - parseExpression (p) (p2,matcher) { - optional ReadSequence> choices <- empty - p2 <- p - while (!p2.pastForwardEnd()) { - p2, optional ReadSequence> sequence <- parseSequence(p2) - if (!present(sequence)) { - break - } - choices <- LinkedNode>$create( - MatchBranches$create(BranchSequence$create(sequence)),choices) - if (p2.pastForwardEnd() || p2.readCurrent() != '|') { - break - } - p2 <- p2.forward() - } - if (!present(choices)) { - matcher <- MatchEmpty$create() - } else { - matcher <- MatchChoices$create(choices) - } - } - - @type parseSingleChar (ReadIterator) -> - (ReadIterator,optional MatcherTemplate) - parseSingleChar (p) (p2,matcher) { - // TODO: Needs error handling. - Char c <- p.readCurrent() - p2 <- p.forward() - if (c == '\\') { - matcher <- MatchSingle$create(p2.readCurrent()) - p2 <- p.forward() - } elif (c == '.') { - matcher <- MatchAny$create() - } else { - matcher <- MatchSingle$create(c) - } - } - - @type parseCharChoices (ReadIterator) -> - (ReadIterator,optional MatcherTemplate) - parseCharChoices (p) (p2,matcher) { - p2 <- p - matcher <- empty - optional Char previous <- empty - Bool doRange <- false - optional ReadSequence> choices <- empty - while (!p2.pastForwardEnd()) { - Char c <- p2.readCurrent() - if (c == '\\') { - p2 <- p2.forward() - c <- p2.readCurrent() - } - if (c == ']') { - break - } elif (c == '-' && present(previous) && !doRange) { - doRange <- true - } elif (doRange) { - choices <- LinkedNode>$create(MatchRange$create(require(previous),c),choices) - previous <- empty - doRange <- false - } elif (present(previous)) { - choices <- LinkedNode>$create(MatchSingle$create(require(previous)),choices) - previous <- c - } else { - previous <- c - } - } update { - p2 <- p2.forward() - } - if (present(previous)) { - choices <- LinkedNode>$create(MatchSingle$create(require(previous)),choices) - } - matcher <- MatchChoices$create(choices) - } -} diff --git a/example/regex/regex-demo.0rx b/example/regex/regex-demo.0rx deleted file mode 100644 --- a/example/regex/regex-demo.0rx +++ /dev/null @@ -1,92 +0,0 @@ -concrete RegexDemo { - @type run () -> () -} - -define RegexDemo { - run () { - \ testMatch("","",true) - \ testMatch("","a",false) - \ testMatch(".","a",true) - \ testMatch(".","aa",false) - \ testMatch("a",".",false) - \ testMatch(".+","",false) - \ testMatch(".+","a",true) - \ testMatch(".+","ab",true) - \ testMatch(".*.","a",true) - \ testMatch(".*.","ab",true) - \ testMatch("(ab)*","",true) - \ testMatch("(ab)*","abab",true) - \ testMatch("(ab)*","a",false) - \ testMatch("(ab)*ac","abac",true) - \ testMatch("(ab)*ac","ac",true) - \ testMatch("(ab)*ac","aca",false) - \ testMatch("(ab)*ac","acab",false) - \ testMatch("(ab)*|ac","abab",true) - \ testMatch("(ab)*|ac","ac",true) - \ testMatch("(ab)*|ac","acac",false) - \ testMatch("(ab)*|ac","abac",false) - \ testMatch("a{2}","a",false) - \ testMatch("a{2}","aa",true) - \ testMatch("a{2}","aaa",false) - \ testMatch("a{2,3}","a",false) - \ testMatch("a{2,3}","aa",true) - \ testMatch("a{2,3}","aaa",true) - \ testMatch("a{2,3}","aaaa",false) - \ testMatch("(a+){4}","aaa",false) - \ testMatch("(a+){4}","aaaa",true) - \ testMatch("(a+){4}","aaaaa",true) - \ testMatch("(a+){4}","aaaaaa",true) - \ testMatch("[a-z?]","q",true) - \ testMatch("[a-z?]","-",false) - \ testMatch("[a-z?]","?",true) - \ testMatch("[a-z?]*","abcde?",true) - \ testMatch("[a-z?]*","ab-cde",false) - - // A few malicious regexes from https://en.wikipedia.org/wiki/ReDoS. - // - // The first three below don't finish, due to repeat branching. The - // branching of "a+" is O(sqrt(2)^n) and "(a+)+" is therefore O(2^n). - // - // The first two could still be matched using non-branching repeats, since - // there is a complete overlap between the tail of one repeat and the next - // repeat, and repeats past 1 don't matter. The third could also be if the - // first 30 were expanded at the beginning. - // - // Overall, the safer solution would be to avoid repeat branching, and have - // a disclaimer about matching accuracy with repeated unbounded patterns - // that overlap themselves. - - // \ testMatch("(a+)+","aaaaaaaaaaaaaaaaaaaaaaaa!",false) - // \ testMatch("(a+)+","aaaaaaaaaaaaaaaaaaaaaaaa!",false) - // \ testMatch("([a-zA-Z]+)*","aaaaaaaaaaaaaaaaaaaaaaaa!",false) - // \ testMatch("(.*a){30}","aaaaaaaaaaaaaaaaaaaaaaaa!",false) - \ testMatch("(a|aa)+","aaaaaaaaaaaaaaaaaaaaaaaa!",false) - - // This causes a ton of branching, but it actually finishes. Given m - // unbounded groups in a sequence, the branching is O(n^m). Since n^m - // increases rapidly with n, most sequence branches at any given time will - // not contain repeat branches within them. The exception is that each of - // the m groups will be in separate sequence branches from the beginning, - // *adding* O(sqrt(2)^n) branches. This means the overall complexity is - // O(n^m)+O(sqrt(2)^n): O(n^m) for smaller n, O(sqrt(2)^n) for larger n. - \ testMatch("[ab]*[ac]*[ad]*[ae]*[af]*", - "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaad",true) - } - - @type testMatch (String,String,Bool) -> () - testMatch (pattern,data,expected) { - MatcherTemplate template <- require(CharRegex$parse(pattern)) - \ LazyStream$new() - .append("Trying: regex=\"") - .append(pattern) - .append("\" data=\"") - .append(data) - .append("\" -> ") - .append(expected) - .append("...\n") - .writeTo(SimpleOutput$stderr()) - if (CharRegex$match(template,data) != expected) { - fail("Incorrect match result!") - } - } -} diff --git a/example/regex/regex-test.0rt b/example/regex/regex-test.0rt deleted file mode 100644 --- a/example/regex/regex-test.0rt +++ /dev/null @@ -1,1338 +0,0 @@ -testcase "MatchSingle match" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "x" - MatcherTemplate template <- MatchSingle$create('x') - Matcher matcher <- template.newMatcher() - - if (template.matchesEmpty()) { - fail("matches empty") - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - MatchState state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchComplete())) { - fail(state) - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - // Should only match once. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - // Should match again after reset. - matcher <- template.newMatcher() - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchComplete())) { - fail(state) - } - } -} - - -testcase "MatchSingle non-match" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "x" - MatcherTemplate template <- MatchSingle$create('x') - Matcher matcher <- template.newMatcher() - - MatchState state <- matcher.tryNextMatch('y') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - - // Should keep failing to match. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - } -} - - -testcase "MatchRange match" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "[w-y]" - MatcherTemplate template <- MatchRange$create('w','y') - Matcher matcher <- template.newMatcher() - - if (template.matchesEmpty()) { - fail("matches empty") - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - MatchState state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchComplete())) { - fail(state) - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - // Should only match once. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - // Should match again after reset. - matcher <- template.newMatcher() - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchComplete())) { - fail(state) - } - } -} - - -testcase "MatchRange non-match" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "[w-y]" - MatcherTemplate template <- MatchRange$create('w','y') - Matcher matcher <- template.newMatcher() - - MatchState state <- matcher.tryNextMatch('a') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - - // Should keep failing to match. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - } -} - - -testcase "MatchAny" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "." - MatcherTemplate template <- MatchAny$create() - Matcher matcher <- template.newMatcher() - - if (template.matchesEmpty()) { - fail("matches empty") - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - MatchState state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchComplete())) { - fail(state) - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - // Should only match once. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - // Should match again after reset. - matcher <- template.newMatcher() - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchComplete())) { - fail(state) - } - } -} - - -testcase "MatchEmpty" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "" - MatcherTemplate template <- MatchEmpty$create() - Matcher matcher <- template.newMatcher() - - if (!template.matchesEmpty()) { - fail("doesn't match empty") - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - MatchState state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - // Should match again after reset. - matcher <- template.newMatcher() - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - } -} - - -testcase "MatchRepeat match" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "[w-y]{2,3}" - MatcherTemplate template <- - MatchRepeat$createRange(2,3,MatchRange$create('w','y')) - Matcher matcher <- template.newMatcher() - - if (template.matchesEmpty()) { - fail("matches empty") - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - MatchState state <- MatchState$matchFail() - - // First character. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - // Second character. - state <- matcher.tryNextMatch('y') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - // Third character. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchComplete())) { - fail(state) - } - - // Fourth character. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - // Reset to reuse the matcher. - matcher <- template.newMatcher() - - // Fourth character. - state <- matcher.tryNextMatch('w') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - // Fifth character. - state <- matcher.tryNextMatch('w') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - } -} - - -testcase "MatchRepeat nested" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "(x*){2,}" - MatcherTemplate template <- - MatchRepeat$createRange(2,0, - MatchRepeat$createZeroPlus(MatchSingle$create('x'))) - Matcher matcher <- template.newMatcher() - - if (!template.matchesEmpty()) { - fail("doesn't match empty") - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - MatchState state <- MatchState$matchFail() - - // First character. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - // Second character. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - // Third character. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - } -} - - -testcase "MatchRepeat non-match" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "[w-y]{2,3}" - MatcherTemplate template <- - MatchRepeat$createRange(2,3,MatchRange$create('w','y')) - Matcher matcher <- template.newMatcher() - - MatchState state <- MatchState$matchFail() - - // First character. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - // Second character. - state <- matcher.tryNextMatch('q') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - // Should keep failing to match. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - } -} - - -testcase "MatchRepeat optional suffix" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "(ab*)*" - MatcherTemplate template <- - MatchRepeat$createZeroPlus( - MatchBranches$create( - BranchSequence$create( - LinkedNode>$create(MatchSingle$create('a'), - LinkedNode>$create( - MatchRepeat$createZeroPlus(MatchSingle$create('b')),empty))))) - Matcher matcher <- template.newMatcher() - - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - MatchState state <- MatchState$matchFail() - - // First character. - state <- matcher.tryNextMatch('a') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - // Second character. - state <- matcher.tryNextMatch('b') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - // Third character. - state <- matcher.tryNextMatch('a') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - } -} - - -testcase "MatchChoices match" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "[w-y]|a*" - MatcherTemplate template <- - MatchChoices$create( - LinkedNode>$create(MatchRange$create('w','y'), - LinkedNode>$create( - MatchBranches$create( - BranchRepeat$createZeroPlus(MatchSingle$create('a'))),empty))) - Matcher matcher <- template.newMatcher() - - MatchState state <- MatchState$matchFail() - - if (!template.matchesEmpty()) { - fail("doesn't match empty") - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - // First character. - state <- matcher.tryNextMatch('a') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - - // Second character. - state <- matcher.tryNextMatch('a') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - - // Third character. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - - // Reset to reuse the matcher. - matcher <- template.newMatcher() - - // First character. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchComplete())) { - fail(state) - } - } -} - - -testcase "MatchChoices non-match" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "[w-y]|a*" - MatcherTemplate template <- - MatchChoices$create( - LinkedNode>$create(MatchRange$create('w','y'), - LinkedNode>$create( - MatchBranches$create( - BranchRepeat$createZeroPlus(MatchSingle$create('a'))),empty))) - Matcher matcher <- template.newMatcher() - - if (!template.matchesEmpty()) { - fail("doesn't match empty") - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - MatchState state <- MatchState$matchFail() - - // First character. - state <- matcher.tryNextMatch('a') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - - // Should keep failing to match. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - } -} - - -testcase "MatchChoices empty choice" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "[w-y]|a{2,2}|" - MatcherTemplate template <- - MatchChoices$create( - LinkedNode>$create(MatchRange$create('w','y'), - LinkedNode>$create( - MatchBranches$create( - BranchRepeat$createRange(2,2,MatchSingle$create('a'))), - LinkedNode>$create( - MatchEmpty$create(),empty)))) - Matcher matcher <- template.newMatcher() - - if (!template.matchesEmpty()) { - fail("doesn't match empty") - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - MatchState state <- MatchState$matchFail() - - // First character. - state <- matcher.tryNextMatch('a') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - } -} - - -testcase "BranchRepeat match" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "[w-y]{2,3}" - MatchBrancherTemplate template <- - BranchRepeat$createRange(2,3,MatchRange$create('w','y')) - MatchBrancher brancher <- template.newBrancher() - - if (template.matchesEmpty()) { - fail("matches empty") - } - if (brancher.matchSatisfied()) { - fail("match satisfied") - } - - MatchState state <- MatchState$matchFail() - optional ReadSequence> branches <- empty - - // First character. - state, branches <- brancher.tryBranches('x') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!present(branches)) { - fail("branch missing") - } - - brancher <- require(branches).value() - if (brancher.matchSatisfied()) { - fail("match satisfied") - } - branches <- require(branches).next() - if (present(branches)) { - fail("branch present") - } - - // Second character. - state, branches <- brancher.tryBranches('y') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!present(branches)) { - fail("branch missing") - } - if (!brancher.matchSatisfied()) { - fail("match not satisfied") - } - - brancher <- require(branches).value() - branches <- require(branches).next() - if (present(branches)) { - fail("branch present") - } - - // Third character. - state, branches <- brancher.tryBranches('x') - if (!(state `MatchState$equals` MatchState$matchComplete())) { - fail(state) - } - if (present(branches)) { - fail("branch present") - } - - // Reset to reuse the brancher. - brancher <- template.newBrancher() - - // Fourth character. - state, branches <- brancher.tryBranches('w') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!present(branches)) { - fail("branch missing") - } - } -} - - -testcase "BranchRepeat nested" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "(x*){2,}" - MatchBrancherTemplate template <- - BranchRepeat$createRange(2,0, - MatchBranches$create( - BranchRepeat$createZeroPlus(MatchSingle$create('x')))) - MatchBrancher brancher <- template.newBrancher() - - if (!template.matchesEmpty()) { - fail("doesn't match empty") - } - if (!brancher.matchSatisfied()) { - fail("match not satisfied") - } - - MatchState state <- MatchState$matchFail() - optional ReadSequence> branches <- empty - - // First character. - state, branches <- brancher.tryBranches('x') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!present(branches)) { - fail("branch missing") - } - - brancher <- require(branches).value() - if (!brancher.matchSatisfied()) { - fail("match not satisfied") - } - branches <- require(branches).next() - if (present(branches)) { - fail("branch present") - } - - // Second character. - state, branches <- brancher.tryBranches('x') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!present(branches)) { - fail("branch missing") - } - - brancher <- require(branches).value() - if (!brancher.matchSatisfied()) { - fail("match not satisfied") - } - // Expect one additional branch to continue "xx*". - branches <- require(branches).next() - if (!present(branches)) { - fail("branch missing") - } - - // Third character, branch 1. - state, _ <- brancher.tryBranches('x') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - - brancher <- require(branches).value() - if (!brancher.matchSatisfied()) { - fail("match not satisfied") - } - // No more branches expected. - branches <- require(branches).next() - if (present(branches)) { - fail("branch present") - } - - // Third character, branch 2. - state, _ <- brancher.tryBranches('x') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - } -} - - -testcase "BranchRepeat non-match" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "[w-y]{2,3}" - MatchBrancherTemplate template <- - BranchRepeat$createRange(2,3,MatchRange$create('w','y')) - MatchBrancher brancher <- template.newBrancher() - - MatchState state <- MatchState$matchFail() - optional ReadSequence> branches <- empty - - // First character. - state, branches <- brancher.tryBranches('x') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!present(branches)) { - fail("branch missing") - } - - brancher <- require(branches).value() - if (brancher.matchSatisfied()) { - fail("match satisfied") - } - branches <- require(branches).next() - if (present(branches)) { - fail("branch present") - } - - // Second character. - state, branches <- brancher.tryBranches('q') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - if (present(branches)) { - fail("branch present") - } - } -} - - -testcase "BranchSequence match" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "[w-y]a" - MatchBrancherTemplate template <- - BranchSequence$create( - LinkedNode>$create(MatchRange$create('w','y'), - LinkedNode>$create(MatchSingle$create('a'),empty))) - MatchBrancher brancher <- template.newBrancher() - - if (template.matchesEmpty()) { - fail("matches empty") - } - if (brancher.matchSatisfied()) { - fail("match satisfied") - } - - MatchState state <- MatchState$matchFail() - optional ReadSequence> branches <- empty - - // First character. - state, branches <- brancher.tryBranches('x') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!present(branches)) { - fail("branch missing") - } - - brancher <- require(branches).value() - branches <- require(branches).next() - if (present(branches)) { - fail("branch present") - } - - // Second character. - state, branches <- brancher.tryBranches('a') - if (!(state `MatchState$equals` MatchState$matchComplete())) { - fail(state) - } - if (!present(branches)) { - fail("branch missing") - } - - // The final branch should just be a record of completeness. - if (!require(branches).value().matchSatisfied()) { - fail("match not satisfied") - } - state, branches <- require(branches).value().tryBranches('a') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - - // Reset to reuse the brancher. - brancher <- template.newBrancher() - - // Third character. - state, branches <- brancher.tryBranches('y') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!present(branches)) { - fail("branch missing") - } - } -} - - -testcase "BranchSequence non-match" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "[w-y]a" - MatchBrancherTemplate template <- - BranchSequence$create( - LinkedNode>$create(MatchRange$create('w','y'), - LinkedNode>$create(MatchSingle$create('a'),empty))) - MatchBrancher brancher <- template.newBrancher() - - MatchState state <- MatchState$matchFail() - optional ReadSequence> branches <- empty - - // First character. - state, branches <- brancher.tryBranches('q') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - if (present(branches)) { - fail("branch present") - } - - // Should keep failing to match. - state, branches <- brancher.tryBranches('x') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - } -} - - -testcase "BranchSequence skip empty failed" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "a*b" - MatchBrancherTemplate template <- - BranchSequence$create( - LinkedNode>$create( - MatchBranches$create( - BranchRepeat$createZeroPlus(MatchSingle$create('a'))), - LinkedNode>$create( - MatchSingle$create('b'),empty))) - MatchBrancher brancher <- template.newBrancher() - - if (template.matchesEmpty()) { - fail("matches empty") - } - if (brancher.matchSatisfied()) { - fail("match satisfied") - } - - MatchState state <- MatchState$matchFail() - optional ReadSequence> branches <- empty - - // First character. - state, branches <- brancher.tryBranches('b') - if (!(state `MatchState$equals` MatchState$matchComplete())) { - fail(state) - } - if (!present(branches)) { - fail("branch missing") - } - } -} - - -testcase "BranchSequence fail non-empty field" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "a+b" - MatchBrancherTemplate template <- - BranchSequence$create( - LinkedNode>$create( - MatchBranches$create( - BranchRepeat$createOnePlus(MatchSingle$create('a'))), - LinkedNode>$create( - MatchSingle$create('b'),empty))) - MatchBrancher brancher <- template.newBrancher() - - if (template.matchesEmpty()) { - fail("matches empty") - } - if (brancher.matchSatisfied()) { - fail("match satisfied") - } - - MatchState state <- MatchState$matchFail() - optional ReadSequence> branches <- empty - - // First character. - state, branches <- brancher.tryBranches('b') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - if (present(branches)) { - fail("branch present") - } - } -} - - -testcase "BranchSequence branch sequence multi-match" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "a*a{0,2}" - MatchBrancherTemplate template <- - BranchSequence$create( - LinkedNode>$create( - MatchBranches$create( - BranchRepeat$createZeroPlus(MatchSingle$create('a'))), - LinkedNode>$create( - MatchBranches$create( - BranchRepeat$createRange(0,2,MatchSingle$create('a'))),empty))) - MatchBrancher brancher <- template.newBrancher() - - if (!template.matchesEmpty()) { - fail("doesn't match empty") - } - if (!brancher.matchSatisfied()) { - fail("match not satisfied") - } - - MatchState state <- MatchState$matchFail() - optional ReadSequence> branches <- empty - - // First character. - state, branches <- brancher.tryBranches('a') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!present(branches)) { - fail("branch missing") - } - - brancher <- require(branches).value() - branches <- require(branches).next() - if (!present(branches)) { - fail("branch missing") - } - - // TODO: This assumes that the branches are ordered from longest to shortest - // remaining sequence. - - // Second character, branch 1. - state, _ <- brancher.tryBranches('a') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - - brancher <- require(branches).value() - branches <- require(branches).next() - if (present(branches)) { - fail("branch present") - } - - // Second character, branch 2. - state, _ <- brancher.tryBranches('a') - if (!(state `MatchState$equals` MatchState$matchComplete())) { - fail(state) - } - } -} - - -testcase "MatchBranches match" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "[w-y]a" - MatcherTemplate template <- - MatchBranches$create( - BranchSequence$create( - LinkedNode>$create(MatchRange$create('w','y'), - LinkedNode>$create(MatchSingle$create('a'),empty)))) - Matcher matcher <- template.newMatcher() - - if (template.matchesEmpty()) { - fail("matches empty") - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - MatchState state <- MatchState$matchFail() - - // First character. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - // Second character. - state <- matcher.tryNextMatch('a') - if (!(state `MatchState$equals` MatchState$matchComplete())) { - fail(state) - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - // Reset to reuse the matcher. - matcher <- template.newMatcher() - - // Third character. - state <- matcher.tryNextMatch('y') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - } -} - - -testcase "MatchBranches non-match" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "[w-y]a" - MatcherTemplate template <- - MatchBranches$create( - BranchSequence$create( - LinkedNode>$create(MatchRange$create('w','y'), - LinkedNode>$create(MatchSingle$create('a'),empty)))) - Matcher matcher <- template.newMatcher() - - if (template.matchesEmpty()) { - fail("matches empty") - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - MatchState state <- MatchState$matchFail() - - // First character. - state <- matcher.tryNextMatch('x') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - // Second character. - state <- matcher.tryNextMatch('q') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - // Should keep failing to match. - state <- matcher.tryNextMatch('y') - if (!(state `MatchState$equals` MatchState$matchFail())) { - fail(state) - } - } -} - - -testcase "MatchBranches branched match" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "ab" - MatcherTemplate templateAB <- - MatchBranches$create( - BranchSequence$create( - LinkedNode>$create(MatchSingle$create('a'), - LinkedNode>$create(MatchSingle$create('b'),empty)))) - // Pattern: "ac" - MatcherTemplate templateAC <- - MatchBranches$create( - BranchSequence$create( - LinkedNode>$create(MatchSingle$create('a'), - LinkedNode>$create(MatchSingle$create('c'),empty)))) - // Pattern: "(ab)*ac" - MatcherTemplate template <- - MatchBranches$create( - BranchSequence$create( - LinkedNode>$create( - MatchBranches$create( - BranchRepeat$createZeroPlus(templateAB)), - LinkedNode>$create(templateAC,empty)))) - Matcher matcher <- template.newMatcher() - - MatchState state <- MatchState$matchFail() - - // First character. - state <- matcher.tryNextMatch('a') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - // Second character. - state <- matcher.tryNextMatch('c') - if (!(state `MatchState$equals` MatchState$matchComplete())) { - fail(state) - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - // Reset to reuse the matcher. - matcher <- template.newMatcher() - - // First character. - state <- matcher.tryNextMatch('a') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - // Second character. - state <- matcher.tryNextMatch('b') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - } -} - - -testcase "MatchBranches partial repeat" { - success Test$execute() -} - -concrete Test { - @type execute () -> () -} - -define Test { - execute () { - // Pattern: "(ab)*" - MatcherTemplate template <- - MatchBranches$create( - BranchRepeat$createZeroPlus( - MatchBranches$create( - BranchSequence$create( - LinkedNode>$create(MatchSingle$create('a'), - LinkedNode>$create(MatchSingle$create('b'),empty)))))) - Matcher matcher <- template.newMatcher() - - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - - MatchState state <- MatchState$matchFail() - - // First character. - state <- matcher.tryNextMatch('a') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (matcher.matchSatisfied()) { - fail("match satisfied") - } - - // Second character. - state <- matcher.tryNextMatch('b') - if (!(state `MatchState$equals` MatchState$matchContinue())) { - fail(state) - } - if (!matcher.matchSatisfied()) { - fail("match not satisfied") - } - } -} diff --git a/example/regex/regex.0rp b/example/regex/regex.0rp deleted file mode 100644 --- a/example/regex/regex.0rp +++ /dev/null @@ -1,127 +0,0 @@ -concrete MatchState { - refines Formatted - defines Equals - defines LessThan - - // Ordered from low to high. - - @type matchFail () -> (MatchState) // Matching has failed. - @type matchComplete () -> (MatchState) // End of the pattern. - @type matchContinue () -> (MatchState) // Matching must continue. -} - -@value interface Matcher<#c|> { - // Returns true if the pattern is complete without additional data. - matchSatisfied () -> (Bool) - - // This can be called as long as it returns matchContinue(). The matcher does - // not branch; each call updates it with the next data point in the input. - // - // Returns: - // - matchFail(): The pattern cannot be completed. - // - matchContinue(): Matching can continue; check matchSatisfied() to see if - // more data is required to complete the pattern. - // - matchComplete(): The pattern has been completed and cannot match any - // additional data. - tryNextMatch (#c) -> (MatchState) -} - -@value interface MatcherTemplate<#c|> { - // Returns true if the pattern can match an empty sequence. - matchesEmpty () -> (Bool) - newMatcher () -> (Matcher<#c>) -} - -@value interface MatchBrancher<#c|> { - // Returns true if the pattern is complete without additional data. - matchSatisfied () -> (Bool) - - // NOTE: Calling this invalidates the MatchBrancher. Subsequent calls should - // be done against the returned branches. - // Returns: - // - state: The highest state of the branches checked. - // - branches: All branches with a status of matchContinue(). - tryBranches (#c) -> (MatchState /*state*/, - optional ReadSequence> /*branches*/) -} - -@value interface MatchBrancherTemplate<#c|> { - // Returns true if the pattern can match an empty sequence. - matchesEmpty () -> (Bool) - newBrancher () -> (MatchBrancher<#c>) -} - -concrete MatchSingle<#c> { - #c defines Equals<#c> - - refines MatcherTemplate<#c> - - @type create (#c) -> (MatchSingle<#c>) -} - -concrete MatchRange<#c> { - #c defines LessThan<#c> - - refines MatcherTemplate<#c> - - @type create (#c,#c) -> (MatchRange<#c>) -} - -concrete MatchAny { - refines MatcherTemplate - - @type create () -> (MatchAny) -} - -concrete MatchEmpty { - refines MatcherTemplate - - @type create () -> (MatchEmpty) -} - -concrete MatchRepeat<#c> { - refines MatcherTemplate<#c> - - @type createZeroPlus (MatcherTemplate<#c>) -> (MatchRepeat<#c>) - @type createOnePlus (MatcherTemplate<#c>) -> (MatchRepeat<#c>) - @type createRange (Int,Int,MatcherTemplate<#c>) -> (MatchRepeat<#c>) -} - -concrete MatchChoices<#c> { - refines MatcherTemplate<#c> - - @type create (optional ReadSequence>) -> (MatchChoices<#c>) -} - -concrete MatchBranches<#c> { - refines MatcherTemplate<#c> - - @type create (MatchBrancherTemplate<#c>) -> (MatcherTemplate<#c>) -} - -concrete BranchRepeat<#c> { - refines MatchBrancherTemplate<#c> - - @type createZeroPlus (MatcherTemplate<#c>) -> (BranchRepeat<#c>) - @type createOnePlus (MatcherTemplate<#c>) -> (BranchRepeat<#c>) - @type createRange (Int,Int,MatcherTemplate<#c>) -> (BranchRepeat<#c>) -} - -concrete BranchSequence<#c> { - refines MatchBrancherTemplate<#c> - - @type create (optional ReadSequence>) -> (BranchSequence<#c>) -} - -@value interface ReadSequence<|#c> { - value () -> (#c) - next () -> (optional ReadSequence<#c>) -} - -concrete LinkedNode<#x> { - refines ReadSequence<#x> - - @type create (#x,optional ReadSequence<#x>) -> (ReadSequence<#x>) - @type concatSequences (optional ReadSequence<#x>,optional ReadSequence<#x>) -> - (optional ReadSequence<#x>) -} diff --git a/example/regex/regex.0rx b/example/regex/regex.0rx deleted file mode 100644 --- a/example/regex/regex.0rx +++ /dev/null @@ -1,724 +0,0 @@ -define MatchState { - @value Int enum - @value String name - @category MatchState matchFailVal <- MatchState{ 0, "matchFail" } - @category MatchState matchCompleteVal <- MatchState{ 1, "matchComplete" } - @category MatchState matchContinueVal <- MatchState{ 2, "matchContinue" } - - formatted () { - return "MatchState$" + name + "()" - } - - equals (x,y) { - return x.getEnum() == y.getEnum() - } - - lessThan (x,y) { - return x.getEnum() < y.getEnum() - } - - matchFail () { - return matchFailVal - } - - matchComplete () { - return matchCompleteVal - } - - matchContinue () { - return matchContinueVal - } - - @value getEnum () -> (Int) - getEnum () { - return enum - } -} - -define MatchSingle { - @value #c match - - create (match) { - return MatchSingle<#c>{ match } - } - - matchesEmpty () { - return false - } - - newMatcher () { - return MatchSingleMatcher<#c>$create(match) - } -} - -concrete MatchSingleMatcher<#c> { - #c defines Equals<#c> - - refines Matcher<#c> - - @type create (#c) -> (MatchSingleMatcher<#c>) -} - -define MatchSingleMatcher { - @value #c match - @value MatchState state - - create (match) { - return MatchSingleMatcher<#c>{ match, MatchState$matchContinue() } - } - - matchSatisfied () { - return state `MatchState$equals` MatchState$matchComplete() - } - - tryNextMatch (data) { - if (!(state `MatchState$equals` MatchState$matchContinue())) { - return (state <- MatchState$matchFail()) - } - if (data `#c$equals` match) { - return (state <- MatchState$matchComplete()) - } else { - return (state <- MatchState$matchFail()) - } - } -} - -define MatchRange { - @value #c minMatch - @value #c maxMatch - - create (minMatch,maxMatch) { - return MatchRange<#c>{ minMatch, maxMatch } - } - - matchesEmpty () { - return false - } - - newMatcher () { - return MatchRangeMatcher<#c>$create(minMatch,maxMatch) - } -} - -concrete MatchRangeMatcher<#c> { - #c defines LessThan<#c> - - refines Matcher<#c> - - @type create (#c,#c) -> (MatchRangeMatcher<#c>) -} - -define MatchRangeMatcher { - @value #c minMatch - @value #c maxMatch - @value MatchState state - - create (minMatch,maxMatch) { - return MatchRangeMatcher<#c>{ minMatch, maxMatch, MatchState$matchContinue() } - } - - matchSatisfied () { - return state `MatchState$equals` MatchState$matchComplete() - } - - tryNextMatch (data) { - if (!(state `MatchState$equals` MatchState$matchContinue())) { - return (state <- MatchState$matchFail()) - } - if (!(data `#c$lessThan` minMatch) && !(maxMatch `#c$lessThan` data)) { - return (state <- MatchState$matchComplete()) - } else { - return (state <- MatchState$matchFail()) - } - } -} - -define MatchAny { - create () { - return MatchAny{ } - } - - matchesEmpty () { - return false - } - - newMatcher () { - return MatchAnyMatcher$create() - } -} - -concrete MatchAnyMatcher { - refines Matcher - - @type create () -> (MatchAnyMatcher) -} - -define MatchAnyMatcher { - @value MatchState state - - create () { - return MatchAnyMatcher{ MatchState$matchContinue() } - } - - matchSatisfied () { - return state `MatchState$equals` MatchState$matchComplete() - } - - tryNextMatch (data) { - if (!(state `MatchState$equals` MatchState$matchContinue())) { - return (state <- MatchState$matchFail()) - } - return (state <- MatchState$matchComplete()) - } -} - -define MatchEmpty { - create () { - return MatchEmpty{ } - } - - matchesEmpty () { - return true - } - - newMatcher () { - return MatchEmptyMatcher$create() - } -} - -concrete MatchEmptyMatcher { - refines Matcher - - @type create () -> (MatchEmptyMatcher) -} - -define MatchEmptyMatcher { - @value Bool failed - - create () { - return MatchEmptyMatcher{ false } - } - - matchSatisfied () { - return !failed - } - - tryNextMatch (data) { - failed <- true - return MatchState$matchFail() - } -} - -define MatchRepeat { - @value MatcherTemplate<#c> template - @value Int minCount - @value Int maxCount - - createZeroPlus (template) { - return createRange(0,0,template) - } - - createOnePlus (template) { - return createRange(1,0,template) - } - - createRange (minCount,maxCount,template) { - return MatchRepeat<#c>{ template, minCount, maxCount } - } - - matchesEmpty () { - return minCount <= 0 || template.matchesEmpty() - } - - newMatcher () { - return MatchRepeatMatcher<#c>$create(minCount,maxCount,template) - } -} - -concrete MatchRepeatMatcher<#c> { - refines Matcher<#c> - - @type create (Int,Int,MatcherTemplate<#c>) -> (MatchRepeatMatcher<#c>) -} - -define MatchRepeatMatcher { - @value MatcherTemplate<#c> template - @value Matcher<#c> matcher - @value Int minCount - @value Int maxCount // 0 means unlimited. - @value Int repetitionCount - @value MatchState lastState - - create (minCount,maxCount,template) { - return MatchRepeatMatcher<#c>{ template, template.newMatcher(), minCount, - maxCount, 0, MatchState$matchComplete() } - } - - matchSatisfied () { - if (lastState `MatchState$equals` MatchState$matchFail()) { - return false - } - if (lastState `MatchState$equals` MatchState$matchContinue() && - (repetitionCount+1 >= minCount || template.matchesEmpty()) && - matcher.matchSatisfied()) { - // The rest of the current repetition can be ignored. - return true - } - if (lastState `MatchState$equals` MatchState$matchComplete() && - (repetitionCount >= minCount || template.matchesEmpty())) { - return true - } - return false - } - - tryNextMatch (data) (state) { - if (atMax() || lastState `MatchState$equals` MatchState$matchFail()) { - return MatchState$matchFail() - } - Bool canSkip <- matcher.matchSatisfied() - state <- matcher.tryNextMatch(data) - if (state `MatchState$equals` MatchState$matchFail() && - lastState `MatchState$equals` MatchState$matchContinue() && canSkip) { - // Handle the case where an optional end to the pattern can be skipped. - \ incrementMatch() - \ startRepeat() - state <- matcher.tryNextMatch(data) - } - lastState <- state - if (state `MatchState$equals` MatchState$matchComplete()) { - \ incrementMatch() - \ startRepeat() - if (atMax()) { - state <- MatchState$matchComplete() - } else { - state <- MatchState$matchContinue() - } - } - } - - @value incrementMatch () -> () - incrementMatch () { - repetitionCount <- repetitionCount+1 - } - - @value atMax () -> (Bool) - atMax () { - return maxCount > 0 && repetitionCount >= maxCount - } - - @value startRepeat () -> () - startRepeat () { - matcher <- template.newMatcher() - } -} - -define MatchChoices { - @value optional ReadSequence> choices - - create (choices) { - return MatchChoices<#c>{ choices } - } - - matchesEmpty () { - scoped { - optional ReadSequence> current <- choices - } in while (present(current)) { - if (require(current).value().matchesEmpty()) { - return true - } - } update { - current <- require(current).next() - } - return false - } - - newMatcher () { - return MatchChoicesMatcher<#c>$create(recursiveNewMatcher(choices)) - } - - @type recursiveNewMatcher (optional ReadSequence>) -> - (optional ReadSequence>) - recursiveNewMatcher (choices) { - if (!present(choices)) { - return empty - } - return LinkedNode>$create(require(choices).value().newMatcher(), - recursiveNewMatcher(require(choices).next())) - } -} - -concrete MatchChoicesMatcher<#c> { - refines Matcher<#c> - - @type create (optional ReadSequence>) -> (MatchChoicesMatcher<#c>) -} - -define MatchChoicesMatcher { - @value optional ReadSequence> choices - - create (choices) { - return MatchChoicesMatcher<#c>{ choices } - } - - matchSatisfied () { - scoped { - optional ReadSequence> current <- choices - } in while (present(current)) { - if (require(current).value().matchSatisfied()) { - return true - } - } update { - current <- require(current).next() - } - return false - } - - tryNextMatch (data) (state) { - state <- MatchState$matchFail() - scoped { - optional ReadSequence> current <- choices - } in while (present(current)) { - // NOTE: Failing matchers are left in for simplicity, under the assumption - // that they will keep failing. - MatchState state2 <- require(current).value().tryNextMatch(data) - if (state `MatchState$lessThan` state2) { - state <- state2 - } - } update { - current <- require(current).next() - } - } -} - -define MatchBranches { - @value MatchBrancherTemplate<#c> template - - create (template) { - return MatchBranches<#c>{ template } - } - - matchesEmpty () { - return template.matchesEmpty() - } - - newMatcher () { - return MatchBranchesMatcher<#c>$create(template.newBrancher()) - } -} - -concrete MatchBranchesMatcher<#c> { - refines Matcher<#c> - - @type create (MatchBrancher<#c>) -> (MatchBranchesMatcher<#c>) -} - -define MatchBranchesMatcher { - @value optional ReadSequence> branches - @value Bool complete - - create (brancher) { - return MatchBranchesMatcher<#c>{ LinkedNode>$create(brancher,empty), false } - } - - matchSatisfied () { - if (complete) { - return true - } - scoped { - optional ReadSequence> current <- branches - } in while (present(current)) { - if (require(current).value().matchSatisfied()) { - return true - } - } update { - current <- require(current).next() - } - return false - } - - tryNextMatch (data) (state) { - state <- MatchState$matchFail() - optional ReadSequence> current <- branches - branches <- empty - complete <- false - scoped { - } in while(present(current)) { - MatchState state2, optional ReadSequence> branches2 <- - require(current).value().tryBranches(data) - if (state2 `MatchState$equals` MatchState$matchComplete()) { - complete <- true - } - if (state `MatchState$lessThan` state2) { - state <- state2 - } - branches <- LinkedNode>$concatSequences(branches2,branches) - } update { - current <- require(current).next() - } - } -} - -concrete BranchRepeatMatcher<#c> { - refines MatchBrancher<#c> - - @type create (Int,Int,MatcherTemplate<#c>) -> (BranchRepeatMatcher<#c>) - @value tryBranches (#c) -> (MatchState,optional ReadSequence>) -} - -define BranchRepeatMatcher { - @value MatcherTemplate<#c> template - @value Matcher<#c> matcher - @value Int minCount - @value Int maxCount // 0 means unlimited. - @value Int repetitionCount - @value MatchState lastState - - create (minCount,maxCount,template) { - return BranchRepeatMatcher<#c>{ template, template.newMatcher(), minCount, - maxCount, 0, MatchState$matchComplete() } - } - - matchSatisfied () { - if (lastState `MatchState$equals` MatchState$matchFail()) { - return false - } - if (lastState `MatchState$equals` MatchState$matchContinue() && - (repetitionCount+1 >= minCount || template.matchesEmpty()) && - matcher.matchSatisfied()) { - // The rest of the current repetition can be ignored. - return true - } - if (lastState `MatchState$equals` MatchState$matchComplete() && - (repetitionCount >= minCount || template.matchesEmpty())) { - return true - } - return false - } - - tryBranches (data) (state,branch) { - state <- MatchState$matchFail() - branch <- empty - if (atMax() || lastState `MatchState$equals` MatchState$matchFail()) { - return _ - } - if (lastState `MatchState$equals` MatchState$matchContinue()) { - // Handle a possible single branch. - Bool canSkip <- matcher.matchSatisfied() - state <- matcher.tryNextMatch(data) - if (canSkip) { - if (state `MatchState$equals` MatchState$matchContinue()) { - // Add a branch for the optional suffix. - branch <- LinkedNode>$create( - BranchRepeatMatcher<#c>{ template, matcher, minCount, - maxCount, repetitionCount, - MatchState$matchContinue() },empty) - } - // Continue, skipping over the optional suffix. - \ incrementMatch() - \ startRepeat() - if (atMax()) { - // Skipping the branch puts us at the max. - return _ - } - state <- matcher.tryNextMatch(data) - } - } else { - // Branching is not possible. - state <- matcher.tryNextMatch(data) - } - lastState <- state - if (state `MatchState$equals` MatchState$matchComplete()) { - \ incrementMatch() - \ startRepeat() - if (!atMax()) { - branch <- LinkedNode>$create(self,branch) - } - } elif (state `MatchState$equals` MatchState$matchContinue()) { - branch <- LinkedNode>$create(self,branch) - } - if (present(branch)) { - state <- MatchState$matchContinue() - } - } - - @value incrementMatch () -> () - incrementMatch () { - repetitionCount <- repetitionCount+1 - } - - @value atMax () -> (Bool) - atMax () { - return maxCount > 0 && repetitionCount >= maxCount - } - - @value startRepeat () -> () - startRepeat () { - matcher <- template.newMatcher() - } -} - -define BranchSequence { - @value optional ReadSequence> sequence - - create (sequence) { - return BranchSequence<#c>{ sequence } - } - - matchesEmpty () { - scoped { - optional ReadSequence> current <- sequence - } in while (present(current)) { - if (!require(current).value().matchesEmpty()) { - return false - } - } update { - current <- require(current).next() - } - return true - } - - newBrancher () { - return BranchSequenceMatcher<#c>$create(sequence) - } -} - -concrete BranchSequenceMatcher<#c> { - refines MatchBrancher<#c> - - @type create (optional ReadSequence>) -> (BranchSequenceMatcher<#c>) - @value tryBranches (#c) -> (MatchState,optional ReadSequence>) -} - -define BranchSequenceMatcher { - @value optional Matcher<#c> continued - @value optional ReadSequence> sequence - @value Bool consumed - - create (sequence) { - return BranchSequenceMatcher<#c>{ empty, sequence, false } - } - - matchSatisfied () { - if (consumed) { - return false - } - if (present(continued) && !require(continued).matchSatisfied()) { - return false - } - scoped { - optional ReadSequence> current <- sequence - } in while (present(current)) { - if (!require(current).value().matchesEmpty()) { - return false - } - } update { - current <- require(current).next() - } - return true - } - - tryBranches (data) { - if (consumed) { - return MatchState$matchFail(), empty - } - consumed <- true - return recursiveBranch(data,continued,sequence) - } - - @type recursiveBranch (#c,optional Matcher<#c>,optional ReadSequence>) -> - (MatchState,optional ReadSequence>) - recursiveBranch (data,continued,sequence) (state,branch) { - state <- MatchState$matchFail() - branch <- empty - if (!present(continued) && !present(sequence)) { - return _ - } - optional Matcher<#c> continued2 <- continued - optional ReadSequence> sequence2 <- sequence - if (!present(continued2)) { - continued2 <- require(sequence2).value().newMatcher() - sequence2 <- require(sequence2).next() - } - if (require(continued2).matchSatisfied()) { - MatchState state2, branch <- recursiveBranch(data,empty,sequence2) - if (state `MatchState$lessThan` state2) { - state <- state2 - } - } - MatchState state2 <- require(continued2).tryNextMatch(data) - if (state `MatchState$lessThan` state2) { - state <- state2 - } - if (state2 `MatchState$equals` MatchState$matchComplete()) { - if (present(sequence2)) { - // Add a branch to continue this sequence. - branch <- LinkedNode>$create( - BranchSequenceMatcher<#c>{ empty, sequence2, false },branch) - state <- MatchState$matchContinue() - } else { - // Add a branch to serve as a record of completeness. It will fail to - // match anything, but matchSatisfied() will return true. - branch <- LinkedNode>$create( - BranchSequenceMatcher<#c>{ empty, empty, false },branch) - } - } elif (state `MatchState$equals` MatchState$matchContinue()) { - // Add a branch to continue this sequence. - branch <- LinkedNode>$create( - BranchSequenceMatcher<#c>{ continued2, sequence2, false },branch) - } - } -} - -define BranchRepeat { - @value MatcherTemplate<#c> template - @value Int minCount - @value Int maxCount - - createZeroPlus (template) { - return createRange(0,0,template) - } - - createOnePlus (template) { - return createRange(1,0,template) - } - - createRange (minCount,maxCount,template) { - return BranchRepeat<#c>{ template, minCount, maxCount } - } - - matchesEmpty () { - return minCount <= 0 || template.matchesEmpty() - } - - newBrancher () { - return BranchRepeatMatcher<#c>$create(minCount,maxCount,template) - } -} - -define LinkedNode { - @value optional ReadSequence<#x> nextNode - @value #x data - - create (data,nextNode) { - return LinkedNode<#x>{ nextNode, data } - } - - concatSequences (head1,head2) { - if (!present(head2)) { - return head1 - } elif (present(head1)) { - return LinkedNode<#x>$create(require(head1).value(), - concatSequences(require(head1).next(),head2)) - } else { - return head2 - } - } - - value () { - return data - } - - next () { - return nextNode - } -} diff --git a/lib/file/Category_RawFileReader.cpp b/lib/file/Category_RawFileReader.cpp --- a/lib/file/Category_RawFileReader.cpp +++ b/lib/file/Category_RawFileReader.cpp @@ -114,7 +114,8 @@ } struct Value_RawFileReader : public TypeValue { Value_RawFileReader(Type_RawFileReader& p, const ParamTuple& params, const ValueTuple& args) - : parent(p), file(new std::ifstream(args.At(0)->AsString(), std::ios::in | std::ios::binary)) {} + : parent(p), filename(args.At(0)->AsString()), + file(new std::ifstream(filename, std::ios::in | std::ios::binary)) {} ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { using CallType = ReturnTuple(Value_RawFileReader::*)(const S&, const ParamTuple&, const ValueTuple&); @@ -156,7 +157,9 @@ Type_RawFileReader& parent; std::mutex mutex; + const std::string filename; R file; + CAPTURE_CREATION }; S CreateValue(Type_RawFileReader& parent, const ParamTuple& params, const ValueTuple& args) { return S_get(new Value_RawFileReader(parent, params, args)); @@ -199,10 +202,14 @@ ReturnTuple Value_RawFileReader::Call_readBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { TRACE_FUNCTION("RawFileReader.readBlock") + TRACE_CREATION std::lock_guard lock(mutex); const PrimInt Var_arg1 = (args.At(0))->AsInt(); if (Var_arg1 < 0) { FAIL() << "Read size " << Var_arg1 << " is invalid"; + } + if (!file || file->rdstate() != std::ios::goodbit) { + FAIL() << "Error reading file \"" << filename << "\""; } std::string buffer(Var_arg1, '\x00'); int read_size = 0; diff --git a/lib/file/Category_RawFileWriter.cpp b/lib/file/Category_RawFileWriter.cpp --- a/lib/file/Category_RawFileWriter.cpp +++ b/lib/file/Category_RawFileWriter.cpp @@ -114,7 +114,8 @@ } struct Value_RawFileWriter : public TypeValue { Value_RawFileWriter(Type_RawFileWriter& p, const ParamTuple& params, const ValueTuple& args) - : parent(p), file(new std::ofstream(args.At(0)->AsString(), std::ios::out | std::ios::binary | std::ios::trunc | std::ios::ate)) {} + : parent(p), filename(args.At(0)->AsString()), + file(new std::ofstream(filename, std::ios::out | std::ios::binary | std::ios::trunc | std::ios::ate)) {} ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { using CallType = ReturnTuple(Value_RawFileWriter::*)(const S&, const ParamTuple&, const ValueTuple&); @@ -154,7 +155,9 @@ Type_RawFileWriter& parent; std::mutex mutex; + const std::string filename; R file; + CAPTURE_CREATION }; S CreateValue(Type_RawFileWriter& parent, const ParamTuple& params, const ValueTuple& args) { return S_get(new Value_RawFileWriter(parent, params, args)); @@ -188,8 +191,12 @@ } ReturnTuple Value_RawFileWriter::Call_writeBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { TRACE_FUNCTION("RawFileWriter.writeBlock") + TRACE_CREATION std::lock_guard lock(mutex); const PrimString& Var_arg1 = args.At(0)->AsString(); + if (!file || file->rdstate() != std::ios::goodbit) { + FAIL() << "Error writing file \"" << filename << "\""; + } int write_size = 0; if (file) { file->write(&Var_arg1[0], Var_arg1.size()); diff --git a/lib/file/tests.0rt b/lib/file/tests.0rt --- a/lib/file/tests.0rt +++ b/lib/file/tests.0rt @@ -103,17 +103,24 @@ if (!present(reader.getFileError())) { fail("expected file error") } + } +} - String data <- reader.readBlock(10) - if (data != "") { - fail("\"" + data + "\"") - } - if (!present(reader.getFileError())) { - fail("expected file error") - } - if (!reader.pastEnd()) { - fail("more data in file") - } +concrete Test { + @type run () -> () +} + + +testcase "read missing file crash" { + crash Test$run() + require "do-not-create-this-file" + require "RawFileReader .*originally created" +} + +define Test { + run () { + RawFileReader reader <- RawFileReader$open("do-not-create-this-file") + \ reader.readBlock(0) } } @@ -128,10 +135,30 @@ define Test { run () { - RawFileWriter writer <- RawFileWriter$open("/") + RawFileWriter writer <- RawFileWriter$open("testfile") + \ writer.freeResource() if (!present(writer.getFileError())) { fail("expected file error") } + } +} + +concrete Test { + @type run () -> () +} + + +testcase "unwritable file crash" { + crash Test$run() + require "testfile" + require "RawFileWriter .*originally created" +} + +define Test { + run () { + RawFileWriter writer <- RawFileWriter$open("testfile") + \ writer.freeResource() + \ writer.writeBlock("") } } diff --git a/lib/util/.zeolite-module b/lib/util/.zeolite-module --- a/lib/util/.zeolite-module +++ b/lib/util/.zeolite-module @@ -1,5 +1,14 @@ root: ".." path: "util" +expression_map: [ + expression_macro { + name: BLOCK_READ_SIZE + expression: \x1000 + } +] +private_deps: [ + "../../tests" +] extra_files: [ category_source { source: "util/Category_Argv.cpp" diff --git a/lib/util/tests.0rt b/lib/util/tests.0rt --- a/lib/util/tests.0rt +++ b/lib/util/tests.0rt @@ -217,3 +217,143 @@ concrete Test { @type run () -> () } + + +testcase "TextReader readAll" { + success Test$run() +} + +concrete FakeFile { + refines BlockReader + + @type create () -> (FakeFile) +} + +define FakeFile { + @value Int counter + + create () { + return FakeFile{ 0 } + } + + readBlock (_) { + cleanup { + counter <- counter+1 + } in if (counter == 0) { + return "this is a " + } elif (counter == 1) { + return "partial line\nwith " + } elif (counter == 2) { + return "some more data\nand\nmore lines" + } elif (counter == 3) { + return "\nunfinished" + } else { + fail("too many reads") + } + } + + pastEnd () { + return counter > 3 + } +} + +define Test { + run () { + String allContents <- TextReader$readAll(FakeFile$create()) + \ Testing$check(allContents,"this is a partial line\nwith some more data\nand\nmore lines\nunfinished") + } +} + +concrete Test { + @type run () -> () +} + + +testcase "ErrorOr value" { + success Test$run() +} + +define Test { + run () { + ErrorOr value <- ErrorOr$$value(10) + if (value.isError()) { + fail("Failed") + } + \ Testing$check(value.getValue(),10) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "ErrorOr getError() crashes with value" { + crash Test$run() + require "empty" +} + +define Test { + run () { + ErrorOr value <- ErrorOr$$value(10) + \ value.getError() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "ErrorOr error" { + success Test$run() +} + +define Test { + run () { + ErrorOr value <- ErrorOr$$error("error message") + if (!value.isError()) { + fail("Failed") + } + \ Testing$check(value.getError().formatted(),"error message") + } +} + +concrete Test { + @type run () -> () +} + + +testcase "ErrorOr getValue() crashes with error" { + crash Test$run() + require "error message" +} + +define Test { + run () { + ErrorOr value <- ErrorOr$$error("error message") + \ value.getValue() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "ErrorOr convert error" { + success Test$run() +} + +define Test { + run () { + scoped { + ErrorOr error <- ErrorOr$$error("error message") + } in ErrorOr value <- error.convertError() + \ Testing$check(value.getError().formatted(),"error message") + } +} + +concrete Test { + @type run () -> () +} diff --git a/lib/util/util.0rp b/lib/util/util.0rp --- a/lib/util/util.0rp +++ b/lib/util/util.0rp @@ -18,6 +18,15 @@ // TODO: Split this up, or otherwise organize it better. +concrete Void { + refines Formatted + + defines Equals + defines LessThan + + @type void () -> (Void) +} + @value interface ReadCurrent<|#x> { readCurrent () -> (#x) } @@ -88,6 +97,18 @@ concrete TextReader { @type fromBlockReader (BlockReader) -> (TextReader) + @type readAll (BlockReader) -> (String) @value readNextLine () -> (String) @value pastEnd () -> (Bool) +} + +concrete ErrorOr<|#x> { + @category value<#x> (#x) -> (ErrorOr<#x>) + @category error (Formatted) -> (ErrorOr) + + @value isError () -> (Bool) + + @value getValue () -> (#x) + @value getError () -> (Formatted) + @value convertError () -> (ErrorOr) } diff --git a/lib/util/util.0rx b/lib/util/util.0rx --- a/lib/util/util.0rx +++ b/lib/util/util.0rx @@ -16,6 +16,26 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] +define Void { + @category Void singleton <- Void{ } + + formatted () { + return "void" + } + + equals (_,_) { + return true + } + + lessThan (_,_) { + return true + } + + void () { + return singleton + } +} + define ReadIterator { @value ReadPosition<#x> reader @value Int position @@ -99,6 +119,14 @@ return TextReader{ reader, "" } } + readAll (reader) { + Builder builder <- String$builder() + while (!reader.pastEnd()) { + \ builder.append(reader.readBlock($ExprLookup[BLOCK_READ_SIZE]$)) + } + return builder.build() + } + readNextLine () { while (true) { Int newline <- findNewline() @@ -108,8 +136,7 @@ buffer <- "" } in return buffer } else { - // TODO: Maybe the block size should be a factory argument. - buffer <- buffer+reader.readBlock(\x100) + buffer <- buffer+reader.readBlock($ExprLookup[BLOCK_READ_SIZE]$) } } else { return takeLine(newline) @@ -143,5 +170,38 @@ String data <- buffer.subSequence(0,position) buffer <- buffer.subSequence(position+1,buffer.readSize()-position-1) return data + } +} + +define ErrorOr { + @value optional #x maybeValue + @value optional Formatted maybeError + + value (x) { + return ErrorOr<#x>{ x, empty } + } + + error (message) { + return ErrorOr{ empty, message } + } + + isError () { + return !present(maybeValue) && present(maybeError) + } + + getValue () { + if (present(maybeValue)) { + return require(maybeValue) + } else { + fail(require(maybeError)) + } + } + + getError () { + return require(maybeError) + } + + convertError () { + return ErrorOr{ empty, maybeError } } } diff --git a/src/Cli/CompileMetadata.hs b/src/Cli/CompileMetadata.hs --- a/src/Cli/CompileMetadata.hs +++ b/src/Cli/CompileMetadata.hs @@ -28,9 +28,11 @@ ) where import Data.List (nub) +import Text.Parsec (SourcePos) import Cli.CompileOptions import Config.Programs (VersionHash) +import Types.Procedure (Expression) import Types.TypeCategory (Namespace) import Types.TypeInstance (CategoryName) @@ -91,10 +93,23 @@ ModuleConfig { rmRoot :: FilePath, rmPath :: FilePath, + rmExprMap :: [(String,Expression SourcePos)], rmPublicDeps :: [FilePath], rmPrivateDeps :: [FilePath], rmExtraFiles :: [ExtraSource], rmExtraPaths :: [FilePath], rmMode :: CompileMode } - deriving (Eq,Show) + deriving (Show) + +instance Eq ModuleConfig where + (ModuleConfig pA dA _ isA is2A esA epA mA) == (ModuleConfig pB dB _ isB is2B esB epB mB) = + all id [ + pA == pB, + dA == dB, + isA == isB, + is2A == is2B, + esA == esB, + epA == epB, + mA == mB + ] diff --git a/src/Cli/Compiler.hs b/src/Cli/Compiler.hs --- a/src/Cli/Compiler.hs +++ b/src/Cli/Compiler.hs @@ -33,6 +33,7 @@ import System.Posix.Temp (mkstemps) import System.IO import Text.Parsec (SourcePos) +import qualified Data.Map as Map import qualified Data.Set as Set import Base.CompileError @@ -41,6 +42,7 @@ import Cli.ProcessMetadata import Cli.TestRunner -- Not safe, due to Text.Regex.TDFA. import Compilation.CompileInfo +import Compilation.ProcedureContext (ExprMap) import CompilerCxx.Category import CompilerCxx.Naming import Config.LoadConfig @@ -58,6 +60,7 @@ ModuleSpec { msRoot :: FilePath, msPath :: FilePath, + msExprMap :: ExprMap SourcePos, msPublicDeps :: [FilePath], msPrivateDeps :: [FilePath], msPublicFiles :: [FilePath], @@ -75,20 +78,24 @@ ltRoot :: FilePath, ltPath :: FilePath, ltMetadata :: CompileMetadata, + ltExprMap :: ExprMap SourcePos, ltPublicDeps :: [CompileMetadata], ltPrivateDeps :: [CompileMetadata] } deriving (Show) compileModule :: ModuleSpec -> IO () -compileModule (ModuleSpec p d is is2 ps xs ts es ep m f) = do +compileModule (ModuleSpec p d em is is2 ps xs ts es ep m f) = do (backend,resolver) <- loadConfig let hash = getCompilerHash backend as <- fmap fixPaths $ sequence $ map (resolveModule resolver (p d)) is as2 <- fmap fixPaths $ sequence $ map (resolveModule resolver (p d)) is2 - (fr1,deps1) <- loadPublicDeps hash as + let ca0 = Map.empty + (fr1,deps1) <- loadPublicDeps hash ca0 as + let ca1 = ca0 `Map.union` mapMetadata deps1 checkAllowedStale fr1 f - (fr2,deps2) <- loadPublicDeps hash as2 + (fr2,deps2) <- loadPublicDeps hash ca1 as2 + let ca2 = ca1 `Map.union` mapMetadata deps2 checkAllowedStale fr2 f base <- resolveBaseModule resolver actual <- resolveModule resolver p d @@ -97,12 +104,12 @@ deps1' <- if isBase then return deps1 else do - (fr3,bpDeps) <- loadPublicDeps hash [base] + (fr3,bpDeps) <- loadPublicDeps hash ca2 [base] checkAllowedStale fr3 f return $ bpDeps ++ deps1 ns0 <- createPublicNamespace p d let ex = concat $ map getSourceCategories es - cm <- loadLanguageModule p ns0 ex ps deps1' deps2 + cm <- loadLanguageModule p ns0 ex em ps deps1' deps2 xa <- fmap collectAllOrErrorM $ sequence $ map (loadPrivateSource p) xs let fs = compileAll cm xa eraseCachedData (p d) @@ -243,7 +250,7 @@ hPutStr h $ concat $ map (++ "\n") content hClose h base <- resolveBaseModule r - (fr,deps2) <- loadPrivateDeps (getCompilerHash b) deps + (fr,deps2) <- loadPrivateDeps (getCompilerHash b) (mapMetadata deps) deps checkAllowedStale fr f let lf' = lf ++ getLinkFlagsForDeps deps2 let paths' = fixPaths $ paths ++ base:(getIncludePathsForDeps deps) @@ -264,7 +271,7 @@ createModuleTemplates p d deps1 deps2 = do ns0 <- createPublicNamespace p d (ps,xs,_) <- findSourceFiles p d - cm <- fmap (fmap fst) $ loadLanguageModule p ns0 [] ps deps1 deps2 + cm <- fmap (fmap fst) $ loadLanguageModule p ns0 [] Map.empty ps deps1 deps2 xs' <- zipWithContents p xs let ts = createTemplates cm xs' if isCompileError ts @@ -277,7 +284,7 @@ formatWarnings ts sequence_ $ map writeTemplate $ getCompileSuccess ts where createTemplates cm xs = do - (LanguageModule _ _ _ cs0 ps0 ts0 cs1 ps1 ts1 _) <- cm + (LanguageModule _ _ _ cs0 ps0 ts0 cs1 ps1 ts1 _ _) <- cm ds <- collectAllOrErrorM $ map parseInternalSource xs let ds2 = concat $ map (\(_,_,d2) -> d2) ds tm <- foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1,ts0,ts1] @@ -295,12 +302,12 @@ writeFile n' $ concat $ map (++ "\n") content runModuleTests :: CompilerBackend b => b -> FilePath -> [FilePath] -> LoadedTests -> IO [((Int,Int),CompileInfo ())] -runModuleTests b base tp (LoadedTests p d m deps1 deps2) = do +runModuleTests b base tp (LoadedTests p d m em deps1 deps2) = do let paths = base:(getIncludePathsForDeps deps1) mapM_ showSkipped $ filter (not . isTestAllowed) $ cmTestFiles m ts' <- zipWithContents p $ map (d ) $ filter isTestAllowed $ cmTestFiles m path <- canonicalizePath (p d) - cm <- fmap (fmap fst) $ loadLanguageModule path NoNamespace [] [] deps1 [] + cm <- fmap (fmap fst) $ loadLanguageModule path NoNamespace [] em [] deps1 [] if isCompileError cm then return [((0,0),cm >> return ())] else sequence $ map (runSingleTest b (getCompileSuccess cm) path paths (m:deps2)) ts' where @@ -333,17 +340,19 @@ let testing = any isTestsOnly pragmas return $ PrivateSource ns testing cs' ds -loadLanguageModule :: CompileErrorM m => FilePath -> Namespace -> [CategoryName] -> - [FilePath] -> [CompileMetadata] -> [CompileMetadata] -> - IO (m (LanguageModule SourcePos,([CategoryName],[CategoryName]))) -loadLanguageModule p ns2 ex fs deps1 deps2 = do +loadLanguageModule :: CompileErrorM m => FilePath -> Namespace -> + [CategoryName] -> ExprMap SourcePos -> [FilePath] -> [CompileMetadata] -> + [CompileMetadata] -> IO (m (LanguageModule SourcePos,([CategoryName],[CategoryName]))) +loadLanguageModule p ns2 ex em fs deps1 deps2 = do + let public = Set.fromList $ map cmPath deps1 + let deps2' = filter (\cm -> not $ cmPath cm `Set.member` public) deps2 + let ns0 = filter (not . isNoNamespace) $ getNamespacesForDeps deps1 + let ns1 = filter (not . isNoNamespace) $ getNamespacesForDeps deps2' m0 <- fmap merge $ sequence $ map processAll deps1 - m1 <- fmap merge $ sequence $ map processAll deps2 + m1 <- fmap merge $ sequence $ map processAll deps2' m2 <- loadAllPublic "" fs - return $ construct m0 m1 m2 where - ns0 = filter (not . isNoNamespace) $ getNamespacesForDeps deps1 - ns1 = filter (not . isNoNamespace) $ getNamespacesForDeps deps2 - construct m0 m1 m2 = do + return $ construct m0 m1 m2 ns0 ns1 where + construct m0 m1 m2 ns0 ns1 = do (ps0,_,tsA0,_) <- m0 (ps1,_,tsA1,_) <- m1 (ps2,xs2,tsA2,tsB2) <- m2 @@ -357,7 +366,8 @@ lmPublicLocal = map (setCategoryNamespace ns2) ps2, lmPrivateLocal = map (setCategoryNamespace ns2) xs2, lmTestingLocal = map (setCategoryNamespace ns2) $ tsA2 ++ tsB2, - lmExternal = ex + lmExternal = ex, + lmExprMap = em } return (cm,(map getCategoryName $ ps2++tsA2,map getCategoryName $ xs2++tsB2)) loadPublic p2 p3 = parsePublicSource p3 >>= return . uncurry (partition p2) diff --git a/src/Cli/ParseCompileOptions.hs b/src/Cli/ParseCompileOptions.hs --- a/src/Cli/ParseCompileOptions.hs +++ b/src/Cli/ParseCompileOptions.hs @@ -29,6 +29,7 @@ import System.Exit import System.IO import Text.Regex.TDFA -- Not safe! +import qualified Data.Map as Map import Base.CompileError import Cli.CompileMetadata @@ -103,7 +104,7 @@ exitSuccess where showDeps p = do p' <- canonicalizePath p - m <- loadMetadata p' + m <- loadMetadata Map.empty p' hPutStrLn stdout $ show p' mapM_ showDep (cmObjectFiles m) showDep (CategoryObjectFile c ds _) = do diff --git a/src/Cli/ParseMetadata.hs b/src/Cli/ParseMetadata.hs --- a/src/Cli/ParseMetadata.hs +++ b/src/Cli/ParseMetadata.hs @@ -31,9 +31,12 @@ import Cli.CompileOptions import Config.Programs (VersionHash(..)) import Parser.Common +import Parser.Procedure () +import Parser.Pragma (parseMacroName) import Parser.TypeCategory () import Parser.TypeInstance () import Text.Regex.TDFA -- Not safe! +import Types.Procedure (Expression) import Types.TypeCategory (FunctionName(..),Namespace(..)) import Types.TypeInstance (CategoryName(..)) @@ -265,20 +268,26 @@ instance ConfigFormat ModuleConfig where readConfig = do - p <- parseOptional "root:" "" parseQuoted - d <- parseRequired "path:" parseQuoted - is <- parseOptional "public_deps:" [] (parseList parseQuoted) - is2 <- parseOptional "private_deps:" [] (parseList parseQuoted) - es <- parseOptional "extra_files:" [] (parseList readConfig) - ep <- parseOptional "include_paths:" [] (parseList parseQuoted) - m <- parseRequired "mode:" readConfig - return (ModuleConfig p d is is2 es ep m) + p <- parseOptional "root:" "" parseQuoted + d <- parseRequired "path:" parseQuoted + em <- parseOptional "expression_map:" [] (parseList parseExprMacro) + is <- parseOptional "public_deps:" [] (parseList parseQuoted) + is2 <- parseOptional "private_deps:" [] (parseList parseQuoted) + es <- parseOptional "extra_files:" [] (parseList readConfig) + ep <- parseOptional "include_paths:" [] (parseList parseQuoted) + m <- parseRequired "mode:" readConfig + return (ModuleConfig p d em is is2 es ep m) writeConfig m = do extra <- fmap concat $ collectAllOrErrorM $ map writeConfig $ rmExtraFiles m mode <- writeConfig (rmMode m) + when (not $ null $ rmExprMap m) $ compileError "Only empty expression maps are allowed when writing" return $ [ "root: " ++ show (rmRoot m), "path: " ++ show (rmPath m), + "expression_map: [", + -- NOTE: expression_map isn't output because that would require making + -- all Expression serializable. + "]", "public_deps: [" ] ++ indents (map show $ rmPublicDeps m) ++ [ "]", @@ -362,3 +371,12 @@ ] writeConfig CompileUnspecified = writeConfig (CompileIncremental []) writeConfig _ = compileError "Invalid compile mode" + +parseExprMacro :: Parser (String,Expression SourcePos) +parseExprMacro = do + sepAfter (string_ "expression_macro") + structOpen + n <- parseRequired "name:" parseMacroName + e <- parseRequired "expression:" sourceParser + structClose + return (n,e) diff --git a/src/Cli/ProcessMetadata.hs b/src/Cli/ProcessMetadata.hs --- a/src/Cli/ProcessMetadata.hs +++ b/src/Cli/ProcessMetadata.hs @@ -17,7 +17,9 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com] module Cli.ProcessMetadata ( + MetadataMap, checkAllowedStale, + checkMetadataFreshness, createCachePath, eraseCachedData, findSourceFiles, @@ -25,6 +27,7 @@ fixPaths, getCachedPath, getCacheRelativePath, + getExprMap, getIncludePathsForDeps, getLinkFlagsForDeps, getNamespacesForDeps, @@ -38,6 +41,7 @@ loadPublicDeps, loadTestingDeps, loadMetadata, + mapMetadata, resolveCategoryDeps, resolveObjectDeps, sortCompiledFiles, @@ -55,6 +59,7 @@ import System.Exit (exitFailure) import System.FilePath import System.IO +import Text.Parsec (SourcePos) import qualified Data.Map as Map import qualified Data.Set as Set @@ -63,8 +68,10 @@ import Cli.CompileOptions import Cli.ParseMetadata -- Not safe, due to Text.Regex.TDFA. import Compilation.CompileInfo +import Compilation.ProcedureContext (ExprMap) import CompilerCxx.Category (CxxOutput(..)) import Config.Programs (VersionHash(..)) +import Types.Procedure (Expression(Literal),ValueLiteral(..)) import Types.TypeCategory import Types.TypeInstance @@ -85,30 +92,42 @@ "Recompile them or use -f to force." exitFailure -loadMetadata :: FilePath -> IO CompileMetadata -loadMetadata p = do - let f = p cachedDataPath metadataFilename - isFile <- doesFileExist p - when isFile $ do - hPutStrLn stderr $ "Path \"" ++ p ++ "\" is not a directory." - exitFailure - isDir <- doesDirectoryExist p - when (not isDir) $ do - hPutStrLn stderr $ "Path \"" ++ p ++ "\" does not exist." - exitFailure - filePresent <- doesFileExist f - when (not filePresent) $ do - hPutStrLn stderr $ "Module \"" ++ p ++ "\" has not been compiled yet." - exitFailure - c <- readFile f - let m = autoReadConfig f c - if isCompileError m - then do - hPutStrLn stderr $ "Could not parse metadata from \"" ++ p ++ "\"; please recompile." - hPutStrLn stderr $ show (getCompileError m) - exitFailure - else return (getCompileSuccess m) +type MetadataMap = Map.Map FilePath CompileMetadata +mapMetadata :: [CompileMetadata] -> MetadataMap +mapMetadata cs = Map.fromList $ zip (map cmPath cs) cs + +loadMetadata :: MetadataMap -> FilePath -> IO CompileMetadata +loadMetadata ca p = do + path <- canonicalizePath p + case path `Map.lookup` ca of + Just cm -> return cm + Nothing -> do + let f = p cachedDataPath metadataFilename + isFile <- doesFileExist p + when isFile $ do + hPutStrLn stderr $ "Path \"" ++ p ++ "\" is not a directory." + exitFailure + isDir <- doesDirectoryExist p + when (not isDir) $ do + hPutStrLn stderr $ "Path \"" ++ p ++ "\" does not exist." + exitFailure + filePresent <- doesFileExist f + when (not filePresent) $ do + hPutStrLn stderr $ "Module \"" ++ p ++ "\" has not been compiled yet." + exitFailure + c <- readFile f + let m = autoReadConfig f c + if isCompileError m + then do + hPutStrLn stderr $ "Could not parse metadata from \"" ++ p ++ "\"; please recompile." + hPutStrLn stderr $ show (getCompileError m) + exitFailure + else return (getCompileSuccess m) + +checkMetadataFreshness :: FilePath -> CompileMetadata -> IO Bool +checkMetadataFreshness = checkModuleFreshness False + tryLoadMetadata :: FilePath -> IO (Maybe CompileMetadata) tryLoadMetadata p = tryLoadData $ (p cachedDataPath metadataFilename) @@ -136,7 +155,7 @@ case m of Nothing -> return False Just _ -> do - (fr,_) <- loadDepsCommon True h Set.empty (\m2 -> cmPublicDeps m2 ++ cmPrivateDeps m2) [p] + (fr,_) <- loadDepsCommon True h Map.empty Set.empty (\m2 -> cmPublicDeps m2 ++ cmPrivateDeps m2) [p] return fr isPathConfigured :: FilePath -> IO Bool @@ -214,6 +233,12 @@ let ts = filter (isSuffixOf ".0rt") ds return (ps,xs,ts) +getExprMap :: FilePath -> ModuleConfig -> IO (ExprMap SourcePos) +getExprMap p m = do + path <- canonicalizePath (p rmRoot m rmPath m) + let defaults = [("MODULE_PATH",Literal (StringLiteral [] path))] + return $ Map.fromList $ rmExprMap m ++ defaults + getRealPathsForDeps :: [CompileMetadata] -> [FilePath] getRealPathsForDeps = map cmPath @@ -233,35 +258,40 @@ getObjectFilesForDeps :: [CompileMetadata] -> [ObjectFile] getObjectFilesForDeps = concat . map cmObjectFiles -loadPublicDeps :: VersionHash -> [FilePath] -> IO (Bool,[CompileMetadata]) -loadPublicDeps h = loadDepsCommon False h Set.empty cmPublicDeps +loadPublicDeps :: VersionHash -> MetadataMap -> [FilePath] -> IO (Bool,[CompileMetadata]) +loadPublicDeps h ca = loadDepsCommon False h ca Set.empty cmPublicDeps -loadTestingDeps :: VersionHash -> CompileMetadata -> IO (Bool,[CompileMetadata]) -loadTestingDeps h m = loadDepsCommon False h (Set.fromList [cmPath m]) cmPublicDeps (cmPublicDeps m ++ cmPrivateDeps m) +loadTestingDeps :: VersionHash -> MetadataMap -> CompileMetadata -> IO (Bool,[CompileMetadata]) +loadTestingDeps h ca m = loadDepsCommon False h ca (Set.fromList [cmPath m]) cmPublicDeps (cmPublicDeps m ++ cmPrivateDeps m) -loadPrivateDeps :: VersionHash -> [CompileMetadata] -> IO (Bool,[CompileMetadata]) -loadPrivateDeps h ms = do - (fr,new) <- loadDepsCommon False h pa (\m -> cmPublicDeps m ++ cmPrivateDeps m) paths +loadPrivateDeps :: VersionHash -> MetadataMap -> [CompileMetadata] -> IO (Bool,[CompileMetadata]) +loadPrivateDeps h ca ms = do + (fr,new) <- loadDepsCommon False h ca pa (\m -> cmPublicDeps m ++ cmPrivateDeps m) paths return (fr,ms ++ new) where paths = concat $ map (\m -> cmPublicDeps m ++ cmPrivateDeps m) ms pa = Set.fromList $ map cmPath ms -loadDepsCommon :: Bool -> VersionHash -> Set.Set FilePath -> +loadDepsCommon :: Bool -> VersionHash -> MetadataMap -> Set.Set FilePath -> (CompileMetadata -> [FilePath]) -> [FilePath] -> IO (Bool,[CompileMetadata]) -loadDepsCommon s h pa0 f ps = fmap snd $ fixedPaths >>= collect (pa0,(True,[])) where +loadDepsCommon s h ca pa0 f ps = fmap snd $ fixedPaths >>= collect (pa0,(True,[])) where fixedPaths = sequence $ map canonicalizePath ps collect xa@(pa,(fr,xs)) (p:ps2) | p `Set.member` pa = collect xa ps2 | otherwise = do - when (not s) $ hPutStrLn stderr $ "Loading metadata for dependency \"" ++ p ++ "\"." - m <- loadMetadata p - fresh <- checkModuleFreshness s p m - when (not s && not fresh) $ - hPutStrLn stderr $ "Module \"" ++ p ++ "\" is out of date and should be recompiled." - let sameVersion = checkModuleVersionHash h m - when (not s && not sameVersion) $ - hPutStrLn stderr $ "Module \"" ++ p ++ "\" was compiled with a different compiler setup." - collect (p `Set.insert` pa,(sameVersion && fresh && fr,xs ++ [m])) (ps2 ++ f m) + (m,fr2) <- + case p `Map.lookup` ca of + Just m2 -> return (m2,True) + Nothing -> do + when (not s) $ hPutStrLn stderr $ "Loading metadata for dependency \"" ++ p ++ "\"." + m2 <- loadMetadata ca p + fresh <- checkModuleFreshness s p m2 + when (not s && not fresh) $ + hPutStrLn stderr $ "Module \"" ++ p ++ "\" is out of date and should be recompiled." + let sameVersion = checkModuleVersionHash h m2 + when (not s && not sameVersion) $ + hPutStrLn stderr $ "Module \"" ++ p ++ "\" was compiled with a different compiler setup." + return (m2,sameVersion && fresh) + collect (p `Set.insert` pa,(fr2 && fr,xs ++ [m])) (ps2 ++ f m) collect xa _ = return xa fixPath :: FilePath -> FilePath diff --git a/src/Cli/RunCompiler.hs b/src/Cli/RunCompiler.hs --- a/src/Cli/RunCompiler.hs +++ b/src/Cli/RunCompiler.hs @@ -27,6 +27,7 @@ import System.FilePath import System.Posix.Temp (mkdtemp) import System.IO +import qualified Data.Map as Map import qualified Data.Set as Set import Base.CompileError @@ -45,21 +46,34 @@ runCompiler (CompileOptions _ _ _ ds _ _ p (ExecuteTests tp) f) = do (backend,resolver) <- loadConfig base <- resolveBaseModule resolver - ts <- sequence $ map (preloadTests backend base) ds + ts <- fmap snd $ foldM (preloadTests backend base) (Map.empty,[]) ds checkTestFilters ts allResults <- fmap concat $ sequence $ map (runModuleTests backend base tp) ts let passed = sum $ map (fst . fst) allResults let failed = sum $ map (snd . fst) allResults processResults passed failed (mergeAllM $ map snd allResults) where - preloadTests b base d = do - m <- loadMetadata (p d) - (fr0,deps0) <- loadPublicDeps (getCompilerHash b) [base] + preloadTests b base (ca,ms) d = do + m <- loadMetadata ca (p d) + let ca2 = ca `Map.union` mapMetadata [m] + fr <- checkMetadataFreshness (p d) m + checkAllowedStale fr f + rm <- tryLoadRecompile (p d) + rm' <- case rm of + Just rm2 -> return rm2 + Nothing -> do + hPutStr stderr $ "Module config for " ++ d ++ " is missing." + exitFailure + (fr0,deps0) <- loadPublicDeps (getCompilerHash b) ca2 [base] + let ca3 = ca2 `Map.union` mapMetadata deps0 checkAllowedStale fr0 f - (fr1,deps1) <- loadTestingDeps (getCompilerHash b) m + (fr1,deps1) <- loadTestingDeps (getCompilerHash b) ca3 m + let ca4 = ca3 `Map.union` mapMetadata deps1 checkAllowedStale fr1 f - (fr2,deps2) <- loadPrivateDeps (getCompilerHash b) (deps0++[m]++deps1) + (fr2,deps2) <- loadPrivateDeps (getCompilerHash b) ca4 (deps0++[m]++deps1) + let ca5 = ca4 `Map.union` mapMetadata deps2 checkAllowedStale fr2 f - return $ LoadedTests p d m (deps0++[m]++deps1) deps2 + em <- getExprMap (p d) rm' + return (ca5,ms ++ [LoadedTests p d m em (deps0++[m]++deps1) deps2]) checkTestFilters ts = do let possibleTests = Set.fromList $ concat $ map (cmTestFiles . ltMetadata) ts case Set.toList $ (Set.fromList tp) `Set.difference` possibleTests of @@ -82,9 +96,21 @@ dir <- mkdtemp "/tmp/zfast_" absolute <- canonicalizePath p f2' <- canonicalizePath (p f2) + let rm = ModuleConfig { + rmRoot = "", + rmPath = ".", + rmExprMap = [], + rmPublicDeps = [], + rmPrivateDeps = [], + rmExtraFiles = [], + rmExtraPaths = [], + rmMode = CompileUnspecified + } + em <- getExprMap p rm let spec = ModuleSpec { msRoot = absolute, msPath = dir, + msExprMap = em, msPublicDeps = is, msPrivateDeps = is2, msPublicFiles = [], @@ -99,22 +125,29 @@ removeDirectoryRecursive dir runCompiler (CompileOptions h _ _ ds _ _ p CompileRecompileRecursive f) = do - foldM recursive Set.empty ds >> return () where - recursive da d0 = do - d <- canonicalizePath (p d0) - rm <- tryLoadRecompile d - case rm of - Nothing -> do - hPutStrLn stderr $ "Path " ++ d ++ " does not have a valid configuration." - exitFailure - Just m -> - if rmPath m `Set.member` da - then return da - else do - let ds3 = map (\d2 -> d d2) (rmPublicDeps m ++ rmPrivateDeps m) - da' <- foldM recursive (rmPath m `Set.insert` da) ds3 - runCompiler (CompileOptions h [] [] [d] [] [] p CompileRecompile f) - return da' + (_,resolver) <- loadConfig + foldM (recursive resolver) Set.empty ds >> return () where + recursive r da d0 = do + isSystem <- isSystemModule r p d0 + if isSystem + then do + hPutStrLn stderr $ "Skipping system module " ++ d0 ++ "." + exitFailure + else do + d <- canonicalizePath (p d0) + rm <- tryLoadRecompile d + case rm of + Nothing -> do + hPutStrLn stderr $ "Path " ++ d ++ " does not have a valid configuration." + exitFailure + Just m -> + if rmPath m `Set.member` da + then return da + else do + let ds3 = map (\d2 -> d d2) (rmPublicDeps m ++ rmPrivateDeps m) + da' <- foldM (recursive r) (rmPath m `Set.insert` da) ds3 + runCompiler (CompileOptions h [] [] [d] [] [] p CompileRecompile f) + return da' runCompiler (CompileOptions _ _ _ ds _ _ p CompileRecompile f) = do (backend,_) <- loadConfig @@ -130,15 +163,17 @@ maybeCompile (Just rm') upToDate | f < ForceAll && upToDate = hPutStrLn stderr $ "Path " ++ d0 ++ " is up to date." | otherwise = do - let (ModuleConfig p2 d is is2 es ep m) = rm' + let (ModuleConfig p2 d _ is is2 es ep m) = rm' -- In case the module is manually configured with a p such as "..", -- since the absolute path might not be known ahead of time. absolute <- canonicalizePath (p d0) let fixed = fixPath (absolute p2) (ps,xs,ts) <- findSourceFiles fixed d + em <- getExprMap (p d0) rm' let spec = ModuleSpec { msRoot = fixed, msPath = d, + msExprMap = em, msPublicDeps = is, msPrivateDeps = is2, msPublicFiles = ps, @@ -157,9 +192,9 @@ base <- resolveBaseModule resolver as <- fmap fixPaths $ sequence $ map (resolveModule resolver (p d)) is as2 <- fmap fixPaths $ sequence $ map (resolveModule resolver (p d)) is2 - (fr1,deps1) <- loadPublicDeps (getCompilerHash backend) (base:as) + (fr1,deps1) <- loadPublicDeps (getCompilerHash backend) Map.empty (base:as) checkAllowedStale fr1 f - (fr2,deps2) <- loadPublicDeps (getCompilerHash backend) as2 + (fr2,deps2) <- loadPublicDeps (getCompilerHash backend) (mapMetadata deps1) as2 checkAllowedStale fr2 f path <- canonicalizePath p createModuleTemplates path d deps1 deps2 @@ -178,6 +213,7 @@ let rm = ModuleConfig { rmRoot = absolute, rmPath = d, + rmExprMap = [], rmPublicDeps = as, rmPrivateDeps = as2, rmExtraFiles = es, diff --git a/src/Compilation/CompileInfo.hs b/src/Compilation/CompileInfo.hs --- a/src/Compilation/CompileInfo.hs +++ b/src/Compilation/CompileInfo.hs @@ -112,7 +112,7 @@ result (es,_,ws) = CompileFail ws $ CompileMessage "" es collectOneOrErrorM = result . splitErrorsAndData where result (_,x:_,ws) = CompileSuccess ws x - result ([],_,ws) = CompileFail ws $ CompileMessage "No choices found" [] + result ([],_,ws) = CompileFail ws $ CompileMessage "" [] result (es,_,ws) = CompileFail ws $ CompileMessage "" es reviseErrorM x@(CompileSuccess _ _) _ = x reviseErrorM (CompileFail w (CompileMessage [] ms)) s = CompileFail w $ CompileMessage s ms @@ -122,7 +122,7 @@ instance MergeableM CompileInfo where mergeAnyM = result . splitErrorsAndData where result (_,xs@(_:_),ws) = CompileSuccess ws $ mergeAny xs - result ([],_,ws) = CompileFail ws $ CompileMessage "No choices found" [] + result ([],_,ws) = CompileFail ws $ CompileMessage "" [] result (es,_,ws) = CompileFail ws $ CompileMessage "" es mergeAllM = result . splitErrorsAndData where result ([],xs,ws) = CompileSuccess ws $ mergeAll xs diff --git a/src/Compilation/CompilerState.hs b/src/Compilation/CompilerState.hs --- a/src/Compilation/CompilerState.hs +++ b/src/Compilation/CompilerState.hs @@ -36,9 +36,11 @@ csCheckVariableInit, csClearOutput, csCurrentScope, + csExprLookup, csGetCategoryFunction, csGetCleanup, csGetLoop, + csGetNoTrace, csGetOutput, csGetParamScope, csGetTypeFunction, @@ -53,6 +55,7 @@ csResolver, csSameType, csSetNoReturn, + csSetNoTrace, csStartLoop, csUpdateAssigned, csWrite, @@ -108,6 +111,9 @@ ccGetLoop :: a -> m (LoopSetup s) ccPushCleanup :: a -> CleanupSetup a s -> m a ccGetCleanup :: a -> m (CleanupSetup a s) + ccExprLookup :: a -> [c] -> String -> m (Expression c) + ccSetNoTrace :: a -> Bool -> m a + ccGetNoTrace :: a -> m Bool type ExpressionType = Positional ValueType @@ -232,6 +238,15 @@ csGetCleanup :: CompilerContext c m s a => CompilerState a m (CleanupSetup a s) csGetCleanup = fmap ccGetCleanup get >>= lift + +csExprLookup :: CompilerContext c m s a => [c] -> String -> CompilerState a m (Expression c) +csExprLookup c n = fmap (\x -> ccExprLookup x c n) get >>= lift + +csSetNoTrace :: CompilerContext c m s a => Bool -> CompilerState a m () +csSetNoTrace t = fmap (\x -> ccSetNoTrace x t) get >>= lift >>= put + +csGetNoTrace :: CompilerContext c m s a => CompilerState a m Bool +csGetNoTrace = fmap ccGetNoTrace get >>= lift data CompiledData s = CompiledData { diff --git a/src/Compilation/ProcedureContext.hs b/src/Compilation/ProcedureContext.hs --- a/src/Compilation/ProcedureContext.hs +++ b/src/Compilation/ProcedureContext.hs @@ -21,6 +21,7 @@ {-# LANGUAGE Safe #-} module Compilation.ProcedureContext ( + ExprMap, ProcedureContext(..), ReturnValidation(..), updateArgVariables, @@ -62,9 +63,13 @@ pcOutput :: [String], pcDisallowInit :: Bool, pcLoopSetup :: LoopSetup [String], - pcCleanupSetup :: CleanupSetup (ProcedureContext c) [String] + pcCleanupSetup :: CleanupSetup (ProcedureContext c) [String], + pcExprMap :: ExprMap c, + pcNoTrace :: Bool } +type ExprMap c = Map.Map String (Expression c) + data ReturnValidation c = ValidatePositions { vpReturns :: Positional (PassedValue c) @@ -106,7 +111,9 @@ pcOutput = pcOutput ctx, pcDisallowInit = pcDisallowInit ctx, pcLoopSetup = pcLoopSetup ctx, - pcCleanupSetup = pcCleanupSetup ctx + pcCleanupSetup = pcCleanupSetup ctx, + pcExprMap = pcExprMap ctx, + pcNoTrace = pcNoTrace ctx } ccGetRequired = return . pcRequiredTypes ccGetCategoryFunction ctx c Nothing n = ccGetCategoryFunction ctx c (Just $ pcType ctx) n @@ -134,8 +141,9 @@ getFunction (Just t2@(TypeMerge MergeUnion _)) = compileError $ "Use explicit type conversion to call " ++ show n ++ " for union type " ++ show t2 ++ formatFullContextBrace c - getFunction (Just (TypeMerge MergeIntersect ts)) = - collectOneOrErrorM $ map getFunction $ map Just ts + getFunction (Just ta@(TypeMerge MergeIntersect ts)) = + collectOneOrErrorM (map getFunction $ map Just ts) `reviseError` + ("Function " ++ show n ++ " not available for type " ++ show ta ++ formatFullContextBrace c) getFunction (Just (SingleType (JustParamName p))) = do fa <- ccAllFilters ctx fs <- case p `Map.lookup` fa of @@ -143,10 +151,8 @@ _ -> compileError $ "Param " ++ show p ++ " does not exist" let ts = map tfType $ filter isRequiresFilter fs let ds = map dfType $ filter isDefinesFilter fs - collectOneOrErrorM $ - [compileError $ "Function " ++ show n ++ " not available for param " ++ show p ++ - formatFullContextBrace c] ++ - (map getFunction $ map (Just . SingleType) ts) ++ (map checkDefine ds) + collectOneOrErrorM (map (getFunction . Just . SingleType) ts ++ map checkDefine ds) `reviseError` + ("Function " ++ show n ++ " not available for param " ++ show p ++ formatFullContextBrace c) getFunction (Just (SingleType (JustTypeInstance t2))) -- Same category as the procedure itself. | tiName t2 == pcType ctx = @@ -245,7 +251,9 @@ pcOutput = pcOutput ctx, pcDisallowInit = pcDisallowInit ctx, pcLoopSetup = pcLoopSetup ctx, - pcCleanupSetup = pcCleanupSetup ctx + pcCleanupSetup = pcCleanupSetup ctx, + pcExprMap = pcExprMap ctx, + pcNoTrace = pcNoTrace ctx } ccCheckVariableInit ctx c n = case pcReturns ctx of @@ -272,7 +280,9 @@ pcOutput = pcOutput ctx ++ ss, pcDisallowInit = pcDisallowInit ctx, pcLoopSetup = pcLoopSetup ctx, - pcCleanupSetup = pcCleanupSetup ctx + pcCleanupSetup = pcCleanupSetup ctx, + pcExprMap = pcExprMap ctx, + pcNoTrace = pcNoTrace ctx } ccGetOutput = return . pcOutput ccClearOutput ctx = return $ ProcedureContext { @@ -294,7 +304,9 @@ pcOutput = [], pcDisallowInit = pcDisallowInit ctx, pcLoopSetup = pcLoopSetup ctx, - pcCleanupSetup = pcCleanupSetup ctx + pcCleanupSetup = pcCleanupSetup ctx, + pcExprMap = pcExprMap ctx, + pcNoTrace = pcNoTrace ctx } ccUpdateAssigned ctx n = update (pcReturns ctx) where update (ValidateNames ts ra) = return $ ProcedureContext { @@ -316,7 +328,9 @@ pcOutput = pcOutput ctx, pcDisallowInit = pcDisallowInit ctx, pcLoopSetup = pcLoopSetup ctx, - pcCleanupSetup = pcCleanupSetup ctx + pcCleanupSetup = pcCleanupSetup ctx, + pcExprMap = pcExprMap ctx, + pcNoTrace = pcNoTrace ctx } update _ = return ctx ccInheritReturns ctx cs = return $ ProcedureContext { @@ -338,7 +352,9 @@ pcOutput = pcOutput ctx, pcDisallowInit = pcDisallowInit ctx, pcLoopSetup = pcLoopSetup ctx, - pcCleanupSetup = pcCleanupSetup ctx + pcCleanupSetup = pcCleanupSetup ctx, + pcExprMap = pcExprMap ctx, + pcNoTrace = pcNoTrace ctx } where inherited = foldr combineParallel UnreachableCode (map pcReturns cs) @@ -373,13 +389,18 @@ pcOutput = pcOutput ctx, pcDisallowInit = pcDisallowInit ctx, pcLoopSetup = pcLoopSetup ctx, - pcCleanupSetup = pcCleanupSetup ctx + pcCleanupSetup = pcCleanupSetup ctx, + pcExprMap = pcExprMap ctx, + pcNoTrace = pcNoTrace ctx } where check (ValidatePositions rs) = do let vs' = case vs of Nothing -> Positional [] Just vs2 -> vs2 + -- Check for a count match first, to avoid the default error message. + processPairs_ alwaysPair (fmap pvType rs) vs' `reviseError` + ("In procedure return at " ++ formatFullContext c) processPairs_ checkReturnType rs (Positional $ zip ([0..] :: [Int]) $ pValues vs') `reviseError` ("In procedure return at " ++ formatFullContext c) return () @@ -425,7 +446,9 @@ pcOutput = pcOutput ctx, pcDisallowInit = pcDisallowInit ctx, pcLoopSetup = pcLoopSetup ctx, - pcCleanupSetup = pcCleanupSetup ctx + pcCleanupSetup = pcCleanupSetup ctx, + pcExprMap = pcExprMap ctx, + pcNoTrace = pcNoTrace ctx } ccStartLoop ctx l = return $ ProcedureContext { @@ -447,7 +470,9 @@ pcOutput = pcOutput ctx, pcDisallowInit = pcDisallowInit ctx, pcLoopSetup = l, - pcCleanupSetup = pcCleanupSetup ctx + pcCleanupSetup = pcCleanupSetup ctx, + pcExprMap = pcExprMap ctx, + pcNoTrace = pcNoTrace ctx } ccGetLoop = return . pcLoopSetup ccPushCleanup ctx (CleanupSetup cs ss) = @@ -471,9 +496,40 @@ pcDisallowInit = pcDisallowInit ctx, pcLoopSetup = pcLoopSetup ctx, pcCleanupSetup = CleanupSetup (cs ++ (csReturnContext $ pcCleanupSetup ctx)) - (ss ++ (csCleanup $ pcCleanupSetup ctx)) + (ss ++ (csCleanup $ pcCleanupSetup ctx)), + pcExprMap = pcExprMap ctx, + pcNoTrace = pcNoTrace ctx } ccGetCleanup = return . pcCleanupSetup + ccExprLookup ctx c n = + case n `Map.lookup` pcExprMap ctx of + Nothing -> compileError $ "Env expression " ++ n ++ " is not defined" ++ formatFullContextBrace c + Just e -> return e + ccSetNoTrace ctx t = + return $ ProcedureContext { + pcScope = pcScope ctx, + pcType = pcType ctx, + pcExtParams = pcExtParams ctx, + pcIntParams = pcIntParams ctx, + pcMembers = pcMembers ctx, + pcCategories = pcCategories ctx, + pcAllFilters = pcAllFilters ctx, + pcExtFilters = pcExtFilters ctx, + pcIntFilters = pcIntFilters ctx, + pcParamScopes = pcParamScopes ctx, + pcFunctions = pcFunctions ctx, + pcVariables = pcVariables ctx, + pcReturns = pcReturns ctx, + pcPrimNamed = pcPrimNamed ctx, + pcRequiredTypes = pcRequiredTypes ctx, + pcOutput = pcOutput ctx, + pcDisallowInit = pcDisallowInit ctx, + pcLoopSetup = pcLoopSetup ctx, + pcCleanupSetup = pcCleanupSetup ctx, + pcExprMap = pcExprMap ctx, + pcNoTrace = t + } + ccGetNoTrace = return . pcNoTrace updateReturnVariables :: (Show c, CompileErrorM m, MergeableM m) => (Map.Map VariableName (VariableValue c)) -> diff --git a/src/Compilation/ScopeContext.hs b/src/Compilation/ScopeContext.hs --- a/src/Compilation/ScopeContext.hs +++ b/src/Compilation/ScopeContext.hs @@ -32,6 +32,7 @@ import Base.CompileError import Base.Mergeable +import Compilation.ProcedureContext import Types.DefinedCategory import Types.GeneralType import Types.Positional @@ -50,7 +51,8 @@ scExternalFilters :: [ParamFilter c], scInternalFilters :: [ParamFilter c], scFunctions :: Map.Map FunctionName (ScopedFunction c), - scVariables :: Map.Map VariableName (VariableValue c) + scVariables :: Map.Map VariableName (VariableValue c), + scExprMap :: ExprMap c } data ProcedureScope c = @@ -64,8 +66,8 @@ applyProcedureScope f (ProcedureScope ctx fs) = map (uncurry (f ctx)) fs getProcedureScopes :: (Show c, CompileErrorM m, MergeableM m) => - CategoryMap c -> DefinedCategory c -> m [ProcedureScope c] -getProcedureScopes ta (DefinedCategory c n pi _ _ fi ms ps fs) = do + CategoryMap c -> ExprMap c -> DefinedCategory c -> m [ProcedureScope c] +getProcedureScopes ta em (DefinedCategory c n pi _ _ fi ms ps fs) = do (_,t) <- getConcreteCategory ta (c,n) let params = Positional $ getCategoryParams t let params2 = Positional pi @@ -87,9 +89,9 @@ let cv = Map.union cm0 cm' let tv = Map.union tm0 tm' let vv = Map.union vm0 vm' - let ctxC = ScopeContext ta n params params2 vm filters filters2 fa cv - let ctxT = ScopeContext ta n params params2 vm filters filters2 fa tv - let ctxV = ScopeContext ta n params params2 vm filters filters2 fa vv + 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 return [ProcedureScope ctxC cp,ProcedureScope ctxT tp,ProcedureScope ctxV vp] where builtins t s0 = Map.filter ((<= s0) . vvScope) $ builtinVariables t diff --git a/src/CompilerCxx/Category.hs b/src/CompilerCxx/Category.hs --- a/src/CompilerCxx/Category.hs +++ b/src/CompilerCxx/Category.hs @@ -41,6 +41,7 @@ import Base.CompileError import Base.Mergeable import Compilation.CompilerState +import Compilation.ProcedureContext (ExprMap) import Compilation.ScopeContext import CompilerCxx.CategoryContext import CompilerCxx.Code @@ -50,6 +51,7 @@ import Types.DefinedCategory import Types.GeneralType import Types.Positional +import Types.Pragma import Types.Procedure import Types.TypeCategory import Types.TypeInstance @@ -78,7 +80,8 @@ lmPublicLocal :: [AnyCategory c], lmPrivateLocal :: [AnyCategory c], lmTestingLocal :: [AnyCategory c], - lmExternal :: [CategoryName] + lmExternal :: [CategoryName], + lmExprMap :: ExprMap c } data PrivateSource c = @@ -91,8 +94,11 @@ compileLanguageModule :: (Show c, CompileErrorM m, MergeableM m) => LanguageModule c -> [PrivateSource c] -> m ([CxxOutput],[CxxOutput]) -compileLanguageModule (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 ex) xa = do +compileLanguageModule (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 ex em) xa = do checkSupefluous $ Set.toList $ (Set.fromList ex) `Set.difference` ca + -- Check public sources up front so that error messages aren't duplicated for + -- every source file. + _ <- tmTesting (hxx1,cxx1) <- fmap mergeGeneratedP $ collectAllOrErrorM $ map (compileSourceP tmPublic nsPublic) cs1 (hxx2,cxx2) <- fmap mergeGeneratedP $ collectAllOrErrorM $ map (compileSourceP tmPrivate nsPrivate) ps1 (hxx3,cxx3) <- fmap mergeGeneratedP $ collectAllOrErrorM $ map (compileSourceP tmTesting nsTesting) ts1 @@ -145,7 +151,7 @@ compileDefinition tm ns4 d = do tm' <- mergeInternalInheritance tm d let refines = dcName d `Map.lookup` tm >>= return . getCategoryRefines - compileConcreteDefinition tm' ns4 refines d + compileConcreteDefinition tm' em ns4 refines d mapByName = Map.fromListWith (++) . map (\d -> (dcName d,[d])) ca = Set.fromList $ map getCategoryName $ filter isValueConcrete (cs1 ++ ps1 ++ ts1) checkLocals ds cs2 = mergeAllM $ map (checkLocal $ Set.fromList cs2) ds @@ -180,25 +186,25 @@ compileTestMain :: (Show c, CompileErrorM m, MergeableM m) => LanguageModule c -> PrivateSource c -> Expression c -> m CxxOutput -compileTestMain (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 _) ts2 e = do +compileTestMain (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 _ em) ts2 e = do tm' <- tm - (req,main) <- createTestFile tm' e + (req,main) <- createTestFile tm' em e return $ CxxOutput Nothing testFilename NoNamespace ([psNamespace ts2]++ns0++ns1++ns2) req main where tm = foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1,ts0,ts1,psCategory ts2] compileModuleMain :: (Show c, CompileErrorM m, MergeableM m) => LanguageModule c -> [PrivateSource c] -> CategoryName -> FunctionName -> m CxxOutput -compileModuleMain (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 _) xa n f = do - let resolved = filter (\d -> dcName d == n) $ concat $ map psDefine xa +compileModuleMain (LanguageModule ns0 ns1 ns2 cs0 ps0 _ cs1 ps1 _ _ em) xa n f = do + let resolved = filter (\d -> dcName d == n) $ concat $ map psDefine $ filter (not . psTesting) xa reconcile resolved tm' <- tm let cs = filter (\c -> getCategoryName c == n) $ concat $ map psCategory xa tm'' <- includeNewTypes tm' cs - (ns,main) <- createMainFile tm'' n f + (ns,main) <- createMainFile tm'' em n f return $ CxxOutput Nothing mainFilename NoNamespace ([ns]++ns0++ns1++ns2) [n] main where - tm = foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1,ts0,ts1] + tm = foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1] reconcile [_] = return () - reconcile [] = compileErrorM $ "No matches for main category " ++ show n + reconcile [] = compileErrorM $ "No matches for main category " ++ show n ++ " ($TestsOnly$ sources excluded)" reconcile ds = flip reviseError ("Multiple matches for main category " ++ show n) $ mergeAllM $ map (\d -> compileError $ "Defined at " ++ formatFullContext (dcContext d)) ds @@ -259,7 +265,7 @@ CategoryMap c -> CategoryName -> m CxxOutput compileConcreteTemplate ta n = do (_,t) <- getConcreteCategory ta ([],n) - compileConcreteDefinition ta [] Nothing (defined t) `reviseError` ("In generated template for " ++ show n) where + compileConcreteDefinition ta Map.empty [] Nothing (defined t) `reviseError` ("In generated template for " ++ show n) where defined t = DefinedCategory { dcContext = [], dcName = getCategoryName t, @@ -273,6 +279,7 @@ } defaultFail f = ExecutableProcedure { epContext = [], + epPragmas = [], epEnd = [], epName = sfName f, epArgs = ArgValues [] $ Positional $ map createArg [1..(length $ pValues $ sfArgs f)], @@ -287,11 +294,12 @@ funcName f = show (sfType f) ++ "." ++ show (sfName f) compileConcreteDefinition :: (Show c, CompileErrorM m, MergeableM m) => - CategoryMap c -> [Namespace] -> Maybe [ValueRefine c] -> DefinedCategory c -> m CxxOutput -compileConcreteDefinition ta ns rs dd@(DefinedCategory c n pi _ _ fi ms _ fs) = do + CategoryMap c -> ExprMap c -> [Namespace] -> Maybe [ValueRefine c] -> + DefinedCategory c -> m CxxOutput +compileConcreteDefinition ta em ns rs dd@(DefinedCategory c n pi _ _ fi ms _ fs) = do (_,t) <- getConcreteCategory ta (c,n) let r = CategoryResolver ta - [cp,tp,vp] <- getProcedureScopes ta dd + [cp,tp,vp] <- getProcedureScopes ta em dd cf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure cp tf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure tp vf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure vp @@ -323,6 +331,7 @@ fmap indentCompiled $ mergeAllM $ map (createMember r allFilters) vm, fmap indentCompiled $ createParams, return $ indentCompiled $ onlyCode $ typeName n ++ "& parent;", + return $ indentCompiled $ onlyCodes $ traceCreation (psProcedures vp), return $ onlyCode "};" ] bottom <- mergeAllM $ [ @@ -359,7 +368,7 @@ "CycleCheck<" ++ n2 ++ "> marker(*this);" ] categoryConstructor t ms2 = do - ctx <- getContextForInit ta t dd CategoryScope + ctx <- getContextForInit ta em t dd CategoryScope initMembers <- runDataCompiler (sequence $ map compileLazyInit ms2) ctx let initMembersStr = intercalate ", " $ cdOutput initMembers let initColon = if null initMembersStr then "" else " : " @@ -378,7 +387,7 @@ let initParent = "parent(p)" let initPassed = map (\(i,p) -> paramName p ++ "(*std::get<" ++ show i ++ ">(params))") $ zip ([0..] :: [Int]) ps2 let allInit = intercalate ", " $ initParent:initPassed - ctx <- getContextForInit ta t dd TypeScope + ctx <- getContextForInit ta em t dd TypeScope initMembers <- runDataCompiler (sequence $ map initMember ms2) ctx mergeAllM [ return $ onlyCode $ typeName n ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {", @@ -433,6 +442,9 @@ "const ParamTuple& params," ++ "const ValueTuple& args) final {" ] ++ createFunctionDispatch n ValueScope fs2 ++ ["}"] + traceCreation vp + | any isTraceCreation $ concat $ map (epPragmas . snd) vp = [captureCreationTrace] + | otherwise = [] commonDefineAll :: MergeableM m => AnyCategory c -> [Namespace] -> Maybe [ValueRefine c] -> CompiledData [String] -> @@ -758,9 +770,9 @@ Set.toList req2 createMainFile :: (Show c, CompileErrorM m, MergeableM m) => - CategoryMap c -> CategoryName -> FunctionName -> m (Namespace,[String]) -createMainFile tm n f = flip reviseError ("In the creation of the main binary procedure") $ do - ca <- fmap indentCompiled (compileMainProcedure tm expr) + CategoryMap c -> ExprMap c -> CategoryName -> FunctionName -> m (Namespace,[String]) +createMainFile tm em n f = flip reviseError ("In the creation of the main binary procedure") $ do + ca <- fmap indentCompiled (compileMainProcedure tm em expr) let file = createMainCommon "main" ca (_,t) <- getConcreteCategory tm ([],n) return (getCategoryNamespace t,file) where @@ -769,10 +781,10 @@ expr = Expression [] (TypeCall [] mainType funcCall) [] createTestFile :: (Show c, CompileErrorM m, MergeableM m) => - CategoryMap c -> Expression c -> m ([CategoryName],[String]) -createTestFile tm e = flip reviseError ("In the creation of the test binary procedure") $ do - ca@(CompiledData req _) <- fmap indentCompiled (compileMainProcedure tm e) - let file = createMainCommon "main" ca + CategoryMap c -> ExprMap c -> Expression c -> m ([CategoryName],[String]) +createTestFile tm em e = flip reviseError ("In the creation of the test binary procedure") $ do + ca@(CompiledData req _) <- fmap indentCompiled (compileMainProcedure tm em e) + let file = createMainCommon "test" ca return (Set.toList req,file) getCategoryMentions :: AnyCategory c -> [CategoryName] diff --git a/src/CompilerCxx/CategoryContext.hs b/src/CompilerCxx/CategoryContext.hs --- a/src/CompilerCxx/CategoryContext.hs +++ b/src/CompilerCxx/CategoryContext.hs @@ -19,7 +19,6 @@ {-# LANGUAGE Safe #-} module CompilerCxx.CategoryContext ( - ScopeContext(..), getContextForInit, getMainContext, getProcedureContext, @@ -44,8 +43,9 @@ getContextForInit :: (Show c, CompileErrorM m, MergeableM m) => - CategoryMap c -> AnyCategory c -> DefinedCategory c -> SymbolScope -> m (ProcedureContext c) -getContextForInit tm t d s = do + CategoryMap c -> ExprMap c -> AnyCategory c -> DefinedCategory c -> + SymbolScope -> m (ProcedureContext c) +getContextForInit tm em t d s = do let ps = Positional $ getCategoryParams t -- NOTE: This is always ValueScope for initializer checks. let ms = filter ((== ValueScope) . dmScope) $ dcMembers d @@ -57,9 +57,7 @@ fa <- setInternalFunctions r t (dcFunctions d) let typeInstance = TypeInstance (getCategoryName t) $ fmap (SingleType . JustParamName . vpParam) ps let builtin = Map.filter ((== LocalScope) . vvScope) $ builtinVariables typeInstance - -- Using < ensures that variables can only be referenced after initialization. - -- TODO: This doesn't really help if access is done via a function. - members <- mapMembers $ filter ((< s) . dmScope) (dcMembers d) + members <- mapMembers $ filter ((<= s) . dmScope) (dcMembers d) return $ ProcedureContext { pcScope = s, pcType = getCategoryName t, @@ -79,14 +77,16 @@ pcOutput = [], pcDisallowInit = True, pcLoopSetup = NotInLoop, - pcCleanupSetup = CleanupSetup [] [] + pcCleanupSetup = CleanupSetup [] [], + pcExprMap = em, + pcNoTrace = False } getProcedureContext :: (Show c, CompileErrorM m, MergeableM m) => ScopeContext c -> ScopedFunction c -> ExecutableProcedure c -> m (ProcedureContext c) -getProcedureContext (ScopeContext tm t ps pi ms pa fi fa va) +getProcedureContext (ScopeContext tm t ps pi ms pa fi fa va em) ff@(ScopedFunction _ _ _ s as1 rs1 ps1 fs _) - (ExecutableProcedure _ _ _ as2 rs2 _) = do + (ExecutableProcedure _ _ _ _ as2 rs2 _) = do rs' <- if isUnnamedReturns rs2 then return $ ValidatePositions rs1 else fmap (ValidateNames rs1 . Map.fromList) $ processPairs pairOutput rs1 (nrNames rs2) @@ -135,13 +135,15 @@ pcOutput = [], pcDisallowInit = False, pcLoopSetup = NotInLoop, - pcCleanupSetup = CleanupSetup [] [] + pcCleanupSetup = CleanupSetup [] [], + pcExprMap = em, + pcNoTrace = False } where pairOutput (PassedValue c1 t2) (OutputValue c2 n2) = return $ (n2,PassedValue (c2++c1) t2) -getMainContext :: CompileErrorM m => CategoryMap c -> m (ProcedureContext c) -getMainContext tm = return $ ProcedureContext { +getMainContext :: CompileErrorM m => CategoryMap c -> ExprMap c -> m (ProcedureContext c) +getMainContext tm em = return $ ProcedureContext { pcScope = LocalScope, pcType = CategoryNone, pcExtParams = Positional [], @@ -160,5 +162,7 @@ pcOutput = [], pcDisallowInit = False, pcLoopSetup = NotInLoop, - pcCleanupSetup = CleanupSetup [] [] + pcCleanupSetup = CleanupSetup [] [], + pcExprMap = em, + pcNoTrace = False } diff --git a/src/CompilerCxx/Code.hs b/src/CompilerCxx/Code.hs --- a/src/CompilerCxx/Code.hs +++ b/src/CompilerCxx/Code.hs @@ -22,6 +22,7 @@ ExprValue(..), PrimitiveType(..), categoryBase, + captureCreationTrace, clearCompiled, emptyCode, escapeChar, @@ -36,6 +37,7 @@ predTraceContext, readStoredVariable, setTraceContext, + showCreationTrace, startCleanupTracing, startFunctionTracing, typeBase, @@ -95,6 +97,12 @@ predTraceContext c | null c = "" | otherwise = "PRED_CONTEXT_POINT(" ++ escapeChars (formatFullContext c) ++ ")" + +captureCreationTrace :: String +captureCreationTrace = "CAPTURE_CREATION" + +showCreationTrace :: String +showCreationTrace = "TRACE_CREATION" data PrimitiveType = PrimBool | diff --git a/src/CompilerCxx/Procedure.hs b/src/CompilerCxx/Procedure.hs --- a/src/CompilerCxx/Procedure.hs +++ b/src/CompilerCxx/Procedure.hs @@ -42,6 +42,8 @@ import Base.CompileError import Base.Mergeable import Compilation.CompilerState +import Compilation.ProcedureContext (ExprMap) +import Compilation.ScopeContext import CompilerCxx.CategoryContext import CompilerCxx.Code import CompilerCxx.Naming @@ -50,6 +52,7 @@ import Types.Function import Types.GeneralType import Types.Positional +import Types.Pragma import Types.Procedure import Types.TypeCategory import Types.TypeInstance @@ -59,23 +62,26 @@ ScopeContext c -> ScopedFunction c -> ExecutableProcedure c -> m (CompiledData [String],CompiledData [String]) compileExecutableProcedure ctx ff@(ScopedFunction _ _ _ s as1 rs1 ps1 _ _) - pp@(ExecutableProcedure _ c n as2 rs2 p) = do + pp@(ExecutableProcedure c0 pragmas c n as2 rs2 p) = do ctx' <- getProcedureContext ctx ff pp output <- runDataCompiler compileWithReturn ctx' - return (onlyCode header,wrapProcedure output) + procedureTrace <- setProcedureTrace + creationTrace <- setCreationTrace + return (onlyCode header,wrapProcedure output procedureTrace creationTrace) where t = scName ctx compileWithReturn = do - ctx0 <- getCleanContext + ctx0 <- getCleanContext >>= lift . flip ccSetNoTrace (any isNoTrace pragmas) compileProcedure ctx0 p >>= put unreachable <- csIsUnreachable when (not unreachable) $ doImplicitReturn [] `reviseErrorStateT` ("In implicit return from " ++ show n ++ formatFullContextBrace c) - wrapProcedure output = + wrapProcedure output pt ct = mergeAll $ [ onlyCode header2, - indentCompiled $ onlyCode setProcedureTrace, + indentCompiled $ onlyCodes pt, + indentCompiled $ onlyCodes ct, indentCompiled $ onlyCodes defineReturns, indentCompiled $ onlyCodes nameParams, indentCompiled $ onlyCodes nameArgs, @@ -101,7 +107,15 @@ "(const S& Var_self, const ParamTuple& params, const ValueTuple& args) {" | otherwise = undefined returnType = "ReturnTuple" - setProcedureTrace = startFunctionTracing $ show t ++ "." ++ show n + setProcedureTrace + | any isNoTrace pragmas = return [] + | otherwise = return [startFunctionTracing $ show t ++ "." ++ show n] + setCreationTrace + | not $ any isTraceCreation pragmas = return [] + | s /= ValueScope = + (compileWarningM $ "Creation tracing ignored for " ++ show s ++ + " functions" ++ formatFullContextBrace c0) >> return [] + | otherwise = return [showCreationTrace] defineReturns | isUnnamedReturns rs2 = [] | otherwise = [returnType ++ " returns(" ++ show (length $ pValues rs1) ++ ");"] @@ -125,7 +139,10 @@ compileCondition ctx c e = do (e',ctx') <- lift $ runStateT compile ctx lift (ccGetRequired ctx') >>= csRequiresTypes - return $ predTraceContext c ++ e' + noTrace <- csGetNoTrace + if noTrace + then return e' + else return $ predTraceContext c ++ e' where compile = flip reviseErrorStateT ("In condition at " ++ formatFullContext c) $ do (ts,e') <- compileExpression e @@ -151,11 +168,18 @@ formatFullContext (getStatementContext s) ++ " is unreachable" +maybeSetTrace :: (Show c, CompileErrorM m, MergeableM m, + CompilerContext c m [String] a) => + [c] -> CompilerState a m () +maybeSetTrace c = do + noTrace <- csGetNoTrace + when (not noTrace) $ csWrite $ setTraceContext c + compileStatement :: (Show c, CompileErrorM m, MergeableM m, CompilerContext c m [String] a) => Statement c -> CompilerState a m () compileStatement (EmptyReturn c) = do - csWrite $ setTraceContext c + maybeSetTrace c doImplicitReturn c compileStatement (ExplicitReturn c es) = do es' <- sequence $ map compileExpression $ pValues es @@ -164,7 +188,7 @@ -- Single expression, but possibly multi-return. getReturn [(_,(Positional ts,e))] = do csRegisterReturn c $ Just (Positional ts) - csWrite $ setTraceContext c + maybeSetTrace c autoPositionalCleanup e -- Multi-expression => must all be singles. getReturn rs = do @@ -172,7 +196,7 @@ ("In return at " ++ formatFullContext c) csRegisterReturn c $ Just $ Positional $ map (head . pValues . fst . snd) rs let e = OpaqueMulti $ "ReturnTuple(" ++ intercalate "," (map (useAsUnwrapped . snd . snd) rs) ++ ")" - csWrite $ setTraceContext c + maybeSetTrace c autoPositionalCleanup e checkArity (_,Positional [_]) = return () checkArity (i,Positional ts) = @@ -202,19 +226,22 @@ lift $ (checkValueTypeMatch r fa t0 formattedRequiredValue) `reviseError` ("In fail call at " ++ formatFullContext c) csSetNoReturn - csWrite $ setTraceContext c + maybeSetTrace c csWrite ["BUILTIN_FAIL(" ++ useAsUnwrapped e0 ++ ")"] compileStatement (IgnoreValues c e) = do (_,e') <- compileExpression e - csWrite $ setTraceContext c + maybeSetTrace c csWrite ["(void) (" ++ useAsWhatever e' ++ ");"] compileStatement (Assignment c as e) = do (ts,e') <- compileExpression e r <- csResolver fa <- csAllFilters + -- Check for a count match first, to avoid the default error message. + _ <- processPairsT alwaysPair (fmap assignableName as) ts `reviseErrorStateT` + ("In assignment at " ++ formatFullContext c) _ <- processPairsT (createVariable r fa) as ts `reviseErrorStateT` ("In assignment at " ++ formatFullContext c) - csWrite $ setTraceContext c + maybeSetTrace c variableTypes <- sequence $ map (uncurry getVariableType) $ zip (pValues as) (pValues ts) assignAll (zip3 ([0..] :: [Int]) variableTypes (pValues as)) e' where @@ -275,7 +302,7 @@ let Positional [t2] = ts lift $ (checkValueTypeMatch r fa t2 t1) `reviseError` ("In initialization of " ++ show n ++ " at " ++ formatFullContext c) - csWrite [variableName n ++ "([]() { return " ++ writeStoredVariable t1 e' ++ "; })"] + csWrite [variableName n ++ "([this]() { return " ++ writeStoredVariable t1 e' ++ "; })"] compileVoidExpression :: (Show c, CompileErrorM m, MergeableM m, CompilerContext c m [String] a) => @@ -367,9 +394,12 @@ ctx0' <- lift $ ccClearOutput ctxP ctxCl <- compileProcedure ctx0' p2 p2' <- lift $ ccGetOutput ctxCl + noTrace <- csGetNoTrace -- TODO: It might be helpful to add a new trace-context line for this -- so that the line that triggered the cleanup is still in the trace. - let p2'' = ["{",startCleanupTracing] ++ p2' ++ ["}"] + let p2'' = if noTrace + then [] + else ["{",startCleanupTracing] ++ p2' ++ ["}"] ctxP' <- lift $ ccPushCleanup ctxP (CleanupSetup [ctxCl] p2'') return (ctxP',p2'',ctxCl) Nothing -> return (ctxP,[],ctxP) @@ -595,7 +625,7 @@ fa <- csAllFilters let vt = ValueType RequiredValue $ SingleType $ JustTypeInstance t lift $ (checkValueTypeMatch r fa t' vt) `reviseError` - ("In conversion at " ++ formatFullContext c) + ("In converted call at " ++ formatFullContext c) f' <- lookupValueFunction vt f compileFunctionCall (Just $ useAsUnwrapped e') f' f transform e (ValueCall c f) = do @@ -629,6 +659,9 @@ scoped <- autoScope s let lazy = s == CategoryScope return (Positional [t],readStoredVariable lazy t (scoped ++ variableName n)) +compileExpressionStart (NamedMacro c n) = do + e <- csExprLookup c n + compileExpression e `reviseErrorStateT` ("In env lookup at " ++ formatFullContext c) compileExpressionStart (CategoryCall c t f@(FunctionCall _ n _ _)) = do f' <- csGetCategoryFunction c (Just t) n csRequiresTypes $ Set.fromList [t,sfType f'] @@ -799,12 +832,12 @@ checkArity (i,Positional ts) = compileError $ "Return position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1" checkArg r fa t0 (i,t1) = do - checkValueTypeMatch r fa t1 t0 `reviseError` ("In argument " ++ show i) + checkValueTypeMatch r fa t1 t0 `reviseError` ("In argument " ++ show i ++ " to " ++ show (sfName f)) compileMainProcedure :: (Show c, CompileErrorM m, MergeableM m) => - CategoryMap c -> Expression c -> m (CompiledData [String]) -compileMainProcedure tm e = do - ctx <- getMainContext tm + CategoryMap c -> ExprMap c -> Expression c -> m (CompiledData [String]) +compileMainProcedure tm em e = do + ctx <- getMainContext tm em runDataCompiler compiler ctx where procedure = Procedure [] [IgnoreValues [] e] compiler = do diff --git a/src/Config/LoadConfig.hs b/src/Config/LoadConfig.hs --- a/src/Config/LoadConfig.hs +++ b/src/Config/LoadConfig.hs @@ -34,6 +34,7 @@ import Control.Monad (when) import Data.Hashable (hash) import Data.List (intercalate,isPrefixOf,isSuffixOf) +import Data.Maybe (isJust) import Data.Version (showVersion,versionBranch) import GHC.IO.Handle import Numeric (showHex) @@ -166,17 +167,16 @@ _ -> exitFailure instance PathResolver Resolver where - resolveModule (SimpleResolver ls ps) p m = do - let allowGlobal = not (".." `elem` components) - m0 <- if allowGlobal && any (\l -> isPrefixOf (l ++ "/") m) ls - then getDataFileName m >>= return . (:[]) - else return [] - let m2 = if allowGlobal - then map ( m) ps - else [] - firstExisting m $ [pm] ++ m0 ++ m2 where - components = map stripSlash $ splitPath m - stripSlash = reverse . dropWhile (== '/') . reverse + resolveModule r p m = do + ps2 <- potentialSystemPaths r m + firstExisting m $ [pm] ++ ps2 + isSystemModule r p m = do + isDir <- doesDirectoryExist (pm) + if isDir + then return False + else do + ps2 <- potentialSystemPaths r m + findModule ps2 >>= return . not . isJust resolveBaseModule _ = do let m = "base" m0 <- getDataFileName m @@ -185,13 +185,32 @@ b <- resolveBaseModule r return (f == b) +potentialSystemPaths :: Resolver -> FilePath -> IO [FilePath] +potentialSystemPaths (SimpleResolver ls ps) m = do + let allowGlobal = not (".." `elem` components) + m0 <- if allowGlobal && any (\l -> isPrefixOf (l ++ "/") m) ls + then getDataFileName m >>= return . (:[]) + else return [] + let m2 = if allowGlobal + then map ( m) ps + else [] + return $ m0 ++ m2 where + components = map stripSlash $ splitPath m + stripSlash = reverse . dropWhile (== '/') . reverse + firstExisting :: FilePath -> [FilePath] -> IO FilePath -firstExisting n [] = do - -- TODO: Allow error recovery here. - hPutStrLn stderr $ "Could not find path " ++ n - exitFailure -firstExisting n (p:ps) = do +firstExisting m ps = do + p <- findModule ps + case p of + Nothing -> do + hPutStrLn stderr $ "Could not find path " ++ m + exitFailure + Just p2 -> return p2 + +findModule :: [FilePath] -> IO (Maybe FilePath) +findModule [] = return Nothing +findModule (p:ps) = do isDir <- doesDirectoryExist p if isDir - then canonicalizePath p - else firstExisting n ps + then fmap Just $ canonicalizePath p + else findModule ps diff --git a/src/Config/Paths.hs b/src/Config/Paths.hs --- a/src/Config/Paths.hs +++ b/src/Config/Paths.hs @@ -25,5 +25,6 @@ class PathResolver r where resolveModule :: r -> FilePath -> FilePath -> IO FilePath + isSystemModule :: r -> FilePath -> FilePath -> IO Bool resolveBaseModule :: r -> IO FilePath isBaseModule :: r -> FilePath -> IO Bool diff --git a/src/Parser/Pragma.hs b/src/Parser/Pragma.hs --- a/src/Parser/Pragma.hs +++ b/src/Parser/Pragma.hs @@ -19,10 +19,14 @@ {-# LANGUAGE Safe #-} module Parser.Pragma ( + parseMacroName, parsePragmas, pragmaComment, + pragmaExprLookup, + pragmaNoTrace, pragmaModuleOnly, - pragmaTestsOnly + pragmaTestsOnly, + pragmaTraceCreation, ) where import Control.Monad (when) @@ -40,6 +44,27 @@ pragmaModuleOnly = autoPragma "ModuleOnly" $ Left parseAt where parseAt c = PragmaVisibility [c] ModuleOnly +parseMacroName :: Parser String +parseMacroName = labeled "macro name" $ do + h <- upper <|> char '_' + t <- many (upper <|> digit <|> char '_') + optionalSpace + return (h:t) + +pragmaExprLookup :: Parser (Pragma SourcePos) +pragmaExprLookup = autoPragma "ExprLookup" $ Right parseAt where + parseAt c = do + name <- parseMacroName + return $ PragmaExprLookup [c] name + +pragmaNoTrace :: Parser (Pragma SourcePos) +pragmaNoTrace = autoPragma "NoTrace" $ Left parseAt where + parseAt c = PragmaTracing [c] NoTrace + +pragmaTraceCreation :: Parser (Pragma SourcePos) +pragmaTraceCreation = autoPragma "TraceCreation" $ Left parseAt where + parseAt c = PragmaTracing [c] TraceCreation + pragmaTestsOnly :: Parser (Pragma SourcePos) pragmaTestsOnly = autoPragma "TestsOnly" $ Left parseAt where parseAt c = PragmaVisibility [c] TestsOnly @@ -61,13 +86,14 @@ autoPragma :: String -> Either (SourcePos -> a) (SourcePos -> Parser a) -> Parser a autoPragma p f = do c <- getPosition - try $ pragmaStart >> string_ p + try $ pragmaStart >> string_ p >> notFollowedBy alphaNum hasArgs <- (pragmaArgsStart >> optionalSpace >> return True) <|> return False x <- delegate hasArgs f c if hasArgs then do extra <- manyTill anyChar (string_ "]$") when (not $ null extra) $ fail $ "Content unused by pragma " ++ p ++ ": " ++ extra + optionalSpace else sepAfter pragmaEnd return x where delegate False (Left f2) c = return $ f2 c diff --git a/src/Parser/Procedure.hs b/src/Parser/Procedure.hs --- a/src/Parser/Procedure.hs +++ b/src/Parser/Procedure.hs @@ -28,8 +28,10 @@ import qualified Data.Set as Set import Parser.Common +import Parser.Pragma import Parser.TypeCategory () import Parser.TypeInstance () +import Types.Pragma import Types.Positional import Types.Procedure import Types.TypeCategory @@ -43,10 +45,11 @@ as <- sourceParser rs <- sourceParser sepAfter (string_ "{") + pragmas <- parsePragmas [pragmaNoTrace,pragmaTraceCreation] pp <- sourceParser c2 <- getPosition sepAfter (string_ "}") - return $ ExecutableProcedure [c] [c2] n as rs pp + return $ ExecutableProcedure [c] pragmas [c2] n as rs pp instance ParseFromSource (ArgValues SourcePos) where sourceParser = labeled "procedure arguments" $ do @@ -413,6 +416,7 @@ variableOrUnqualified <|> builtinCall <|> builtinValue <|> + exprLookup <|> try typeOrCategoryCall <|> typeCall where parens = do @@ -440,6 +444,11 @@ c <- getPosition n <- builtinValues return $ NamedVariable (OutputValue [c] (VariableName n)) + exprLookup = do + pragma <- pragmaExprLookup + case pragma of + (PragmaExprLookup c name) -> return $ NamedMacro c name + _ -> undefined -- Should be caught above. variableOrUnqualified = do c <- getPosition n <- sourceParser :: Parser VariableName @@ -488,7 +497,7 @@ charLiteral = do c <- getPosition string_ "'" - ch <- stringChar + ch <- stringChar <|> char '"' string_ "'" optionalSpace return $ CharLiteral [c] ch diff --git a/src/Test/ParseMetadata.hs b/src/Test/ParseMetadata.hs --- a/src/Test/ParseMetadata.hs +++ b/src/Test/ParseMetadata.hs @@ -27,6 +27,10 @@ import Cli.CompileOptions import Cli.ParseMetadata import Config.Programs (VersionHash(..)) +import System.FilePath +import Test.Common +import Types.Positional +import Types.Procedure import Types.TypeCategory (FunctionName(..),Namespace(..)) import Types.TypeInstance (CategoryName(..)) @@ -192,6 +196,7 @@ checkWriteThenRead $ ModuleConfig { rmRoot = "/home/projects", rmPath = "special", + rmExprMap = [], rmPublicDeps = [ "/home/project/public-dep1", "/home/project/public-dep2" @@ -228,6 +233,19 @@ } }, + checkWriteFail "empty.+map" $ ModuleConfig { + rmRoot = "/home/projects", + rmPath = "special", + rmExprMap = [("MACRO",Literal (StringLiteral [] "something"))], + rmPublicDeps = [], + rmPrivateDeps = [], + rmExtraFiles = [], + rmExtraPaths = [], + rmMode = CompileIncremental { + ciLinkFlags = [] + } + }, + checkWriteFail "bad category" $ CategorySource { csSource = "extra1.cpp", csCategories = [ @@ -297,7 +315,21 @@ checkWriteFail "compile mode" $ ExecuteTests { etInclude = [] }, checkWriteFail "compile mode" $ CompileRecompile, checkWriteFail "compile mode" $ CompileRecompileRecursive, - checkWriteFail "compile mode" $ CreateTemplates + checkWriteFail "compile mode" $ CreateTemplates, + + checkParsesAs ("testfiles" "module-config.txt") + (\m -> case rmExprMap m of + [("MY_MACRO", + Expression _ (BuiltinCall _ + (FunctionCall _ BuiltinRequire (Positional []) + (Positional [Literal (EmptyLiteral _)]))) []), + ("MY_OTHER_MACRO", + Expression _ + (TypeCall _ _ + (FunctionCall _ (FunctionName "execute") (Positional []) + (Positional [Literal (StringLiteral _ "this is a string\n")]))) []) + ] -> True + _ -> False) ] checkWriteThenRead :: (Eq a, Show a, ConfigFormat a) => a -> IO (CompileInfo ()) @@ -323,3 +355,16 @@ compileError $ "Expected pattern " ++ show p ++ " in error output but got\n" ++ text | otherwise = compileError $ "Expected write failure but got\n" ++ getCompileSuccess c + +checkParsesAs :: (Show a, ConfigFormat a) => String -> (a -> Bool) -> IO (CompileInfo ()) +checkParsesAs f m = do + contents <- loadFile f + let parsed = autoReadConfig f contents + return $ check parsed contents + where + check x contents = do + x' <- x `reviseError` ("While parsing " ++ f) + when (not $ m x') $ + compileError $ "Failed to match after write/read\n" ++ + "Unparsed:\n" ++ contents ++ "\n" ++ + "Parsed:\n" ++ show x' ++ "\n" diff --git a/src/Test/Pragma.hs b/src/Test/Pragma.hs --- a/src/Test/Pragma.hs +++ b/src/Test/Pragma.hs @@ -42,11 +42,26 @@ [PragmaVisibility _ TestsOnly] -> True _ -> False), + checkParsesAs "$NoTrace$" (fmap (:[]) pragmaNoTrace) + (\e -> case e of + [PragmaTracing _ NoTrace] -> True + _ -> False), + + checkParsesAs "$TraceCreation$" (fmap (:[]) pragmaTraceCreation) + (\e -> case e of + [PragmaTracing _ TraceCreation] -> True + _ -> False), + checkParsesAs "$Comment[ \"this is a pragma with args\" ]$" (fmap (:[]) pragmaComment) (\e -> case e of [PragmaComment _ "this is a pragma with args"] -> True _ -> False), + checkParsesAs "$ExprLookup[ \nMODULE_PATH /*comment*/\n ]$" (fmap (:[]) pragmaExprLookup) + (\e -> case e of + [PragmaExprLookup _ "MODULE_PATH"] -> True + _ -> False), + checkParsesAs "/*only comments*/" (parsePragmas [pragmaModuleOnly,pragmaTestsOnly]) (\e -> case e of [] -> True @@ -73,7 +88,9 @@ checkParseError "$TestsOnly[ extra ]$" "does not allow arguments" pragmaTestsOnly, - checkParseError "$Comment$" "requires arguments" pragmaComment + checkParseError "$Comment$" "requires arguments" pragmaComment, + + checkParseError "$ExprLookup[ \"bad stuff\" ]$" "macro name" pragmaExprLookup ] checkParsesAs :: String -> Parser [Pragma SourcePos] -> ([Pragma SourcePos] -> Bool) -> IO (CompileInfo ()) diff --git a/src/Test/Procedure.hs b/src/Test/Procedure.hs --- a/src/Test/Procedure.hs +++ b/src/Test/Procedure.hs @@ -210,6 +210,11 @@ checkShortParseFail " x <- 'xx'", checkShortParseSuccess " x <- \"'xx\"", + checkParsesAs "'\"'" + (\e -> case e of + (Literal (CharLiteral _ '"')) -> True + _ -> False), + checkParsesAs "1 + 2 < 4 && 3 >= 1 * 2 + 1 || true" (\e -> case e of (InfixExpression _ diff --git a/src/Test/testfiles/module-config.txt b/src/Test/testfiles/module-config.txt new file mode 100644 --- /dev/null +++ b/src/Test/testfiles/module-config.txt @@ -0,0 +1,12 @@ +path: "testfiles" +expression_map: [ + expression_macro { + name: MY_MACRO + expression: require(empty) + } + expression_macro { + name: MY_OTHER_MACRO + expression: Type$execute("this is a string\012") + } +] +mode: incremental {} diff --git a/src/Types/Positional.hs b/src/Types/Positional.hs --- a/src/Types/Positional.hs +++ b/src/Types/Positional.hs @@ -46,8 +46,7 @@ processPairs f (Positional ps1) (Positional ps2) | length ps1 == length ps2 = collectAllOrErrorM $ map (uncurry f) (zip ps1 ps2) - | otherwise = - compileError $ "Parameter count mismatch: " ++ show ps1 ++ " vs. " ++ show ps2 + | otherwise = mismatchError ps1 ps2 processPairs_ :: (Show a, Show b, CompileErrorM m) => (a -> b -> m c) -> Positional a -> Positional b -> m () @@ -58,5 +57,8 @@ processPairsT f (Positional ps1) (Positional ps2) | length ps1 == length ps2 = sequence $ map (uncurry f) (zip ps1 ps2) - | otherwise = - lift $ compileError $ "Parameter count mismatch: " ++ show ps1 ++ " vs. " ++ show ps2 + | otherwise = lift $ mismatchError ps1 ps2 + +mismatchError :: (Show a, Show b, CompileErrorM m) => [a] -> [b] -> m c +mismatchError ps1 ps2 = compileError $ "Count mismatch: " ++ show ps1 ++ + " (expected) vs. " ++ show ps2 ++ " (actual)" diff --git a/src/Types/Pragma.hs b/src/Types/Pragma.hs --- a/src/Types/Pragma.hs +++ b/src/Types/Pragma.hs @@ -21,19 +21,33 @@ module Types.Pragma ( CodeVisibility(..), Pragma(..), + TraceType(..), getPragmaContext, + isExprLookup, isModuleOnly, + isNoTrace, isTestsOnly, + isTraceCreation, ) where data CodeVisibility = ModuleOnly | TestsOnly deriving (Show) +data TraceType = NoTrace | TraceCreation deriving (Show) + data Pragma c = PragmaVisibility { pvContext :: [c], pvScopes :: CodeVisibility } | + PragmaExprLookup { + pelContext :: [c], + pelName :: String + } | + PragmaTracing { + ptContext :: [c], + ptType :: TraceType + } | -- This is mostly for testing purposes. PragmaComment { pcContext :: [c], @@ -43,11 +57,25 @@ getPragmaContext :: Pragma c -> [c] getPragmaContext (PragmaVisibility c _) = c +getPragmaContext (PragmaExprLookup c _) = c +getPragmaContext (PragmaTracing c _) = c getPragmaContext (PragmaComment c _) = c isModuleOnly :: Pragma c -> Bool isModuleOnly (PragmaVisibility _ ModuleOnly) = True isModuleOnly _ = False + +isExprLookup :: Pragma c -> Bool +isExprLookup (PragmaExprLookup _ _) = True +isExprLookup _ = False + +isNoTrace :: Pragma c -> Bool +isNoTrace (PragmaTracing _ NoTrace) = True +isNoTrace _ = False + +isTraceCreation :: Pragma c -> Bool +isTraceCreation (PragmaTracing _ TraceCreation) = True +isTraceCreation _ = False isTestsOnly :: Pragma c -> Bool isTestsOnly (PragmaVisibility _ TestsOnly) = True diff --git a/src/Types/Procedure.hs b/src/Types/Procedure.hs --- a/src/Types/Procedure.hs +++ b/src/Types/Procedure.hs @@ -40,6 +40,7 @@ VariableName(..), VoidExpression(..), WhileLoop(..), + assignableName, getExpressionContext, getStatementContext, isDiscardedInput, @@ -48,6 +49,7 @@ import Data.List (intercalate) +import Types.Pragma import Types.Positional import Types.TypeCategory import Types.TypeInstance @@ -58,6 +60,7 @@ data ExecutableProcedure c = ExecutableProcedure { epContext :: [c], + epPragmas :: [Pragma c], epEnd :: [c], epName :: FunctionName, epArgs :: ArgValues c, @@ -118,6 +121,9 @@ isDiscardedInput (DiscardInput _) = True isDiscardedInput _ = False +discardInputName :: VariableName +discardInputName = VariableName "_" + instance Show c => Show (InputValue c) where show (InputValue c v) = show v ++ " /*" ++ formatFullContext c ++ "*/" show (DiscardInput c) = "_" ++ " /*" ++ formatFullContext c ++ "*/" @@ -162,6 +168,11 @@ ExistingVariable (InputValue c) deriving (Show) +assignableName :: Assignable c -> VariableName +assignableName (CreateVariable _ _ n) = n +assignableName (ExistingVariable (InputValue _ n)) = n +assignableName _ = discardInputName + data VoidExpression c = Conditional (IfElifElse c) | Loop (WhileLoop c) | @@ -222,6 +233,7 @@ data ExpressionStart c = NamedVariable (OutputValue c) | + NamedMacro [c] String | CategoryCall [c] CategoryName (FunctionCall c) | TypeCall [c] TypeInstanceOrParam (FunctionCall c) | UnqualifiedCall [c] (FunctionCall c) | diff --git a/src/Types/TypeCategory.hs b/src/Types/TypeCategory.hs --- a/src/Types/TypeCategory.hs +++ b/src/Types/TypeCategory.hs @@ -165,13 +165,7 @@ formatValue v = show (pfParam v) ++ " " ++ show (pfFilter v) ++ " " ++ formatContext (pfContext v) formatInterfaceFunc f = showFunctionInContext "" " " f - formatConcreteFunc f = showFunctionInContext (showScope (sfScope f) ++ " ") " " f - -showScope :: SymbolScope -> String -showScope CategoryScope = "@category" -showScope TypeScope = "@type" -showScope ValueScope = "@value" -showScope LocalScope = "@local" + formatConcreteFunc f = showFunctionInContext (show (sfScope f) ++ " ") " " f getCategoryName :: AnyCategory c -> CategoryName getCategoryName (ValueInterface _ _ n _ _ _ _) = n @@ -358,8 +352,14 @@ CategoryScope | TypeScope | ValueScope - deriving (Eq,Ord,Show) + deriving (Eq,Ord) +instance Show SymbolScope where + show CategoryScope = "@category" + show TypeScope = "@type" + show ValueScope = "@value" + show LocalScope = "@local" + partitionByScope :: (a -> SymbolScope) -> [a] -> ([a],[a],[a]) partitionByScope f = foldr bin empty where empty = ([],[],[]) @@ -846,8 +846,8 @@ where checkMerge r3 fm3 f1 f2 | sfScope f1 /= sfScope f2 = - compileError $ "Cannot merge " ++ showScope (sfScope f2) ++ " with " ++ - showScope (sfScope f1) ++ " in function merge:\n---\n" ++ + compileError $ "Cannot merge " ++ show (sfScope f2) ++ " with " ++ + show (sfScope f1) ++ " in function merge:\n---\n" ++ show f2 ++ "\n ->\n" ++ show f1 | otherwise = flip reviseError ("In function merge:\n---\n" ++ show f2 ++ @@ -889,7 +889,7 @@ } instance Show c => Show (ScopedFunction c) where - show f = showFunctionInContext (showScope (sfScope f) ++ " ") "" f + show f = showFunctionInContext (show (sfScope f) ++ " ") "" f showFunctionInContext :: Show c => String -> String -> ScopedFunction c -> String showFunctionInContext s indent (ScopedFunction cs n t _ as rs ps fa ms) = diff --git a/src/Types/TypeInstance.hs b/src/Types/TypeInstance.hs --- a/src/Types/TypeInstance.hs +++ b/src/Types/TypeInstance.hs @@ -275,7 +275,8 @@ checkValueTypeMatch r f ts1@(ValueType r1 t1) ts2@(ValueType r2 t2) | r1 < r2 = compileError $ "Cannot convert " ++ show ts1 ++ " to " ++ show ts2 - | otherwise = checkGeneralMatch r f Covariant t1 t2 + | otherwise = checkGeneralMatch r f Covariant t1 t2 `reviseError` + ("Cannot convert " ++ show ts1 ++ " to " ++ show ts2) checkGeneralMatch :: (MergeableM m, CompileErrorM m, TypeResolver r) => r -> ParamFilters -> Variance -> diff --git a/tests/.zeolite-module b/tests/.zeolite-module --- a/tests/.zeolite-module +++ b/tests/.zeolite-module @@ -1,5 +1,20 @@ root: ".." path: "tests" +expression_map: [ + // See expr-lookup.0rt and expr-lookup.0rx. + expression_macro { + name: INT_EXPR + expression: 1+3 + } + expression_macro { + name: LOCAL_VAR + expression: macroLocalVar + } + expression_macro { + name: META_VAR + expression: $ExprLookup[INT_EXPR]$*5 + } +] private_deps: [ "visibility" "visibility2" diff --git a/tests/cli-tests.sh b/tests/cli-tests.sh --- a/tests/cli-tests.sh +++ b/tests/cli-tests.sh @@ -78,6 +78,16 @@ } +test_tests_only2() { + local output=$(do_zeolite -p "$ZEOLITE_PATH" -r tests/tests-only2 || true) + if ! echo "$output" | egrep -q 'main.+ Testing'; then + show_message 'Expected Testing definition error from tests/tests-only:' + echo "$output" 1>&2 + return 1 + fi +} + + test_module_only() { local output=$(do_zeolite -p "$ZEOLITE_PATH" -R tests/module-only || true) if ! echo "$output" | egrep -q 'Type1 not found'; then @@ -115,6 +125,7 @@ define $category { run () { \ LazyStream\$new() + .append(\$ExprLookup[MODULE_PATH]\$ + "\n") .append("Hello World\n") .writeTo(SimpleOutput\$stdout()) } @@ -127,6 +138,11 @@ echo "$output" 1>&2 return 1 fi + if ! echo "$output" | fgrep -xq "$PWD"; then + show_message 'Expected $PWD in program output:' + echo "$output" 1>&2 + return 1 + fi execute rm -r "$temp" "$PWD/$category" || true } @@ -165,22 +181,44 @@ } +test_example_hello() { + do_zeolite -p "$ZEOLITE_PATH" -i lib/util -m HelloDemo example/hello -f + do_zeolite -p "$ZEOLITE_PATH" -t example/hello +} + + +test_example_tree() { + do_zeolite -p "$ZEOLITE_PATH" -i lib/util -m TreeDemo example/tree -f + do_zeolite -p "$ZEOLITE_PATH" -t example/tree +} + + +test_example_parser() { + do_zeolite -p "$ZEOLITE_PATH" -r example/parser -f + do_zeolite -p "$ZEOLITE_PATH" -t example/parser +} + + run_all() { ZEOLITE_PATH=$(do_zeolite --get-path | grep '^/') echo 1>&2 local failed=0 + local list=() for t in "$@"; do show_message "Testing $t >>>" echo 1>&2 if ! "$t"; then failed=1 + list=("${list[@]}" "$t") fi echo 1>&2 show_message "<<< Testing $t" echo 1>&2 done if (($failed)); then - show_message 'One or more tests failed.' + for t in "${list[@]}"; do + show_message "*** $t FAILED ***" + done return 1 else show_message 'All tests passed.' @@ -190,11 +228,15 @@ ALL_TESTS=( test_check_defs test_tests_only + test_tests_only2 test_module_only test_templates test_fast test_bad_system_include test_global_include + test_example_hello + test_example_tree + test_example_parser ) run_all "${ALL_TESTS[@]}" 1>&2 diff --git a/tests/expr-lookup.0rp b/tests/expr-lookup.0rp new file mode 100644 --- /dev/null +++ b/tests/expr-lookup.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] + +$ModuleOnly$ +$TestsOnly$ + +concrete ExprLookup { + @type modulePath () -> (String) + @type intExpr () -> (Int) + @type localVar () -> (Int) +} diff --git a/tests/expr-lookup.0rt b/tests/expr-lookup.0rt new file mode 100644 --- /dev/null +++ b/tests/expr-lookup.0rt @@ -0,0 +1,205 @@ +/* ----------------------------------------------------------------------------- +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 "bad macro name" { + error + require "UNKNOWN_STRING .+not defined" +} + +define Test { + run () { + String value <- $ExprLookup[UNKNOWN_STRING]$ + } +} + +concrete Test { + @type run () -> () +} + + +testcase "MODULE_PATH is absolute" { + crash Test$run() + require "Failed condition: /.+/tests" +} + +define Test { + run () { + fail($ExprLookup[MODULE_PATH]$) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "MODULE_PATH from regular source" { + crash Test$run() + require "Failed condition: /.+/tests" +} + +define Test { + run () { + fail(ExprLookup$modulePath()) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "mismatched macro type" { + error + require "String.+Int" +} + +define Test { + run () { + Int value <- $ExprLookup[MODULE_PATH]$ + } +} + +concrete Test { + @type run () -> () +} + + +testcase "macro used inline in expressions" { + crash Test$run() + require "Failed condition: /.+/tests is the path" +} + +define Test { + run () { + fail($ExprLookup[MODULE_PATH]$ + " is the path") + } +} + +concrete Test { + @type run () -> () +} + + +testcase "constant defined in .zeolite-module" { + success Test$run() +} + +define Test { + run () { + \ Testing$check($ExprLookup[INT_EXPR]$,4) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "constant defined in .zeolite-module from regular source" { + success Test$run() +} + +define Test { + run () { + \ Testing$check(ExprLookup$intExpr(),4) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "in context defined in .zeolite-module" { + success Test$run() +} + +define Test { + @category String macroLocalVar <- "hello" + + run () { + \ Testing$check($ExprLookup[LOCAL_VAR]$,"hello") + } +} + +concrete Test { + @type run () -> () +} + + +testcase "undefined in context defined in .zeolite-module" { + error + require "\.zeolite-module" + require "macroLocalVar" +} + +define Test { + run () { + String value <- $ExprLookup[LOCAL_VAR]$ + } +} + +concrete Test { + @type run () -> () +} + + +testcase "in context defined in .zeolite-module from regular source" { + success Test$run() +} + +define Test { + run () { + \ Testing$check(ExprLookup$localVar(),99) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "nested expression defined in .zeolite-module" { + success Test$run() +} + +define Test { + run () { + \ Testing$check($ExprLookup[META_VAR]$,20) + } +} + +concrete Test { + @type run () -> () +} + + +testcase "function called on expression" { + success Test$run() +} + +define Test { + run () { + \ Testing$check($ExprLookup[INT_EXPR]$.formatted(),"4") + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/expr-lookup.0rx b/tests/expr-lookup.0rx new file mode 100644 --- /dev/null +++ b/tests/expr-lookup.0rx @@ -0,0 +1,34 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +$TestsOnly$ + +define ExprLookup { + modulePath () { + return $ExprLookup[MODULE_PATH]$ + } + + intExpr () { + return $ExprLookup[INT_EXPR]$ + } + + localVar () { + Int macroLocalVar <- 99 + return $ExprLookup[LOCAL_VAR]$ + } +} diff --git a/tests/member-init.0rt b/tests/member-init.0rt --- a/tests/member-init.0rt +++ b/tests/member-init.0rt @@ -93,6 +93,29 @@ } +testcase "@category member refers to @category member" { + success Test$run() +} + +define Test { + @category Int value1 <- 1 + @category Int value2 <- value1+1 + + @category get () -> (Int) + get () { + return value2 + } + + run () { + \ Testing$check(get(),2) + } +} + +concrete Test { + @type run () -> () +} + + testcase "@category member is lazy" { success Test$run() } diff --git a/tests/tests-only/README.md b/tests/tests-only/README.md --- a/tests/tests-only/README.md +++ b/tests/tests-only/README.md @@ -1,4 +1,4 @@ -# `$TestsOnly$` Pragma Test +# `$TestsOnly$` Visibility Test - Incremental Compiling this module should **always fail**. It tests that the `$TestsOnly$` pragma limits visibility to only `.0rx` sources that also have the `$TestsOnly$` diff --git a/tests/tests-only2/.zeolite-module b/tests/tests-only2/.zeolite-module new file mode 100644 --- /dev/null +++ b/tests/tests-only2/.zeolite-module @@ -0,0 +1,6 @@ +root: "../.." +path: "tests/tests-only2" +mode: binary { + category: Testing + function: run +} diff --git a/tests/tests-only2/README.md b/tests/tests-only2/README.md new file mode 100644 --- /dev/null +++ b/tests/tests-only2/README.md @@ -0,0 +1,18 @@ +# `$TestsOnly$` Visibility Test - Binaries + +Compiling this module should **always fail**. It tests that the `$TestsOnly$` +pragma limits visibility of `.0rx` categories to only test binaries. + +To compile: + +```shell +ZEOLITE_PATH=$(zeolite --get-path) +zeolite -p $ZEOLITE_PATH -r tests/tests-only2 +``` + +The compiler errors should look something like this: + +```text +Compiler errors: +No matches for main category Testing ($TestsOnly$ sources excluded) +``` diff --git a/tests/tests-only2/private.0rx b/tests/tests-only2/private.0rx new file mode 100644 --- /dev/null +++ b/tests/tests-only2/private.0rx @@ -0,0 +1,23 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +$TestsOnly$ + +define Testing { + run () {} +} diff --git a/tests/tests-only2/public.0rp b/tests/tests-only2/public.0rp new file mode 100644 --- /dev/null +++ b/tests/tests-only2/public.0rp @@ -0,0 +1,23 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +$TestsOnly$ + +concrete Testing { + @type run () -> () +} diff --git a/tests/tracing.0rt b/tests/tracing.0rt new file mode 100644 --- /dev/null +++ b/tests/tracing.0rt @@ -0,0 +1,177 @@ +/* ----------------------------------------------------------------------------- +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 "NoTrace skips tracing" { + crash Test$run() + require "message" + require "Test\.run" + require "Test\.error" + exclude "Test\.noTrace" +} + +define Test { + run () { + \ noTrace() + } + + @type noTrace () -> () + noTrace () { $NoTrace$ + \ error() + } + + @type error () -> () + error () { + fail("message") + } +} + +concrete Test { + @type run () -> () +} + + +testcase "TraceCreation captures trace" { + crash Test$run() + require "message" + require "Type.+created at" +} + +concrete Type { + @type create () -> (Type) + @value call () -> () +} + +define Type { + create () { + return Type{ } + } + + call () { $TraceCreation$ + fail("message") + } +} + +define Test { + run () { + Type value <- Type$create() + \ value.call() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "TraceCreation ignored in @type" { + success Test$run() + require compiler "tracing ignored" +} + +define Test { + run () { $TraceCreation$ } +} + +concrete Test { + @type run () -> () +} + + +testcase "TraceCreation still works with NoTrace" { + crash Test$run() + require "message" + require "Type.+created at" + exclude "Type\.call" +} + +concrete Type { + @type create () -> (Type) + @value call () -> () +} + +define Type { + create () { + return Type{ } + } + + call () { $NoTrace$ $TraceCreation$ + fail("message") + } +} + +define Test { + run () { + Type value <- Type$create() + \ value.call() + } +} + +concrete Test { + @type run () -> () +} + + +testcase "TraceCreation only uses the latest" { + crash Test$run() + require "message" + require "Type1.+created at" + exclude "Type2.+created at" +} + +concrete Type1 { + @type create () -> (Type1) + @value call () -> () +} + +define Type1 { + create () { + return Type1{ } + } + + call () { $TraceCreation$ + fail("message") + } +} + +concrete Type2 { + @type create () -> (Type2) + @value call () -> () +} + +define Type2 { + @value Type1 value + + create () { + return Type2{ Type1$create() } + } + + call () { $TraceCreation$ + \ value.call() + } +} + +define Test { + run () { + Type2 value <- Type2$create() + \ value.call() + } +} + +concrete Test { + @type run () -> () +} 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.5.0.0 +version: 0.6.0.0 synopsis: Zeolite is a statically-typed, general-purpose programming language. description: @@ -62,7 +62,8 @@ extra-source-files: ChangeLog.md, src/Test/testfiles/*.0rp, src/Test/testfiles/*.0rt, - src/Test/testfiles/*.0rx + src/Test/testfiles/*.0rx, + src/Test/testfiles/*.txt data-files: base/.zeolite-module, base/*.0rp, @@ -72,10 +73,12 @@ base/*.h, example/hello/README.md, example/hello/*.0rx, - example/regex/README.md, - example/regex/*.0rp, - example/regex/*.0rt, - example/regex/*.0rx, + example/parser/.zeolite-module, + example/parser/README.md, + example/parser/*.0rp, + example/parser/*.0rt, + example/parser/*.0rx, + example/parser/*.txt, example/tree/README.md, example/tree/*.0rp, example/tree/*.0rt, @@ -115,6 +118,10 @@ tests/tests-only/.zeolite-module, tests/tests-only/*.0rp, tests/tests-only/*.0rx, + tests/tests-only2/README.md, + tests/tests-only2/.zeolite-module, + tests/tests-only2/*.0rp, + tests/tests-only2/*.0rx, tests/visibility/.zeolite-module, tests/visibility/*.0rp, tests/visibility/*.0rx,