bb13048 · project-m36 · git.iko.soy

git.iko.soy/project-m36

Merge branch 'master' into new_transgraph

# Conflicts: # cabal.project # examples/blog.hs # project-m36.cabal # src/bin/TutorialD/Interpreter.hs # src/bin/TutorialD/Interpreter/Base.hs # src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs # src/bin/TutorialD/Interpreter/Export/Base.hs # src/bin/TutorialD/Interpreter/Import/Base.hs # src/bin/TutorialD/Interpreter/RelationalExpr.hs # src/bin/TutorialD/tutd.hs # src/bin/benchmark/Handles.hs # src/bin/benchmark/bigrel.hs # src/lib/ProjectM36/Atom.hs # src/lib/ProjectM36/AtomType.hs # src/lib/ProjectM36/Atomable.hs # src/lib/ProjectM36/Client.hs # src/lib/ProjectM36/DataFrame.hs # src/lib/ProjectM36/IsomorphicSchema.hs # src/lib/ProjectM36/Key.hs # src/lib/ProjectM36/Relation/Show/HTML.hs # src/lib/ProjectM36/Relation/Show/Term.hs # src/lib/ProjectM36/RelationalExpression.hs # src/lib/ProjectM36/ScriptSession.hs # src/lib/ProjectM36/Server.hs # src/lib/ProjectM36/Server/ParseArgs.hs # src/lib/ProjectM36/Sessions.hs # src/lib/ProjectM36/Transaction/Persist.hs # src/lib/ProjectM36/TransactionGraph.hs # src/lib/ProjectM36/TransactionGraph/Persist.hs # src/lib/ProjectM36/Tupleable.hs # test/Relation/Atomable.hs # test/TutorialD/Interpreter.hs # test/TutorialD/Interpreter/AtomFunctionScript.hs

commitbb13048deabe975d38311ed81d908503d3845714 authorAgentM <agentm@themactionfaction.com> dateSun 24 May 2020, 13:36 (6 years ago) parentb53feae 150d459

61 files changed+952−418

compare with master

unifiedsplit

.appveyor.yml+2−2

@@ -18,7 +18,7 @@ environment:

1818 STACK_ROOT: "c:\\sr"

1919 matrix:

2020 - YAML: "stack.ghc8.2.yaml"

21− - YAML: "stack.ghc8.4.yaml"

21+ - YAML: "stack.ghc8.6.yaml"

2222

2323platform:

2424 - x64

@@ -37,4 +37,4 @@ test_script:

3737

3838#artifacts:

3939# - path: project-m36.7z

40−# name: project-m36.7z

40+# name: project-m36.7z

.travis.yml+11−11

@@ -16,16 +16,16 @@ cache:

1616matrix:

1717 fast_finish: true

1818 include:

19− - env: CACHE_NAME=8.2.2 STACK_YAML=stack.ghc8.2.yaml

20− compiler: ": #stack 8.2.2"

19+ - env: CACHE_NAME=8.4.4 STACK_YAML=stack.ghc8.4.yaml

20+ compiler: ": #stack 8.4.4"

2121

22− - env: CACHE_NAME=osx-8.2.2 STACK_YAML=stack.ghc8.2.yaml

23− os: osx

24− os_image: xcode7.3

25− compiler: ": #stack 8.2.2"

22+ - env: CACHE_NAME=8.6.5 STACK_YAML=stack.ghc8.6.yaml

23+ compiler: ": #stack 8.6.5"

2624

27− - env: CACHE_NAME=8.4.3 STACK_YAML=stack.ghc8.4.yaml

28− compiler: ": #stack 8.4.3"

25+ - env: CACHE_NAME=osx-8.6.5 STACK_YAML=stack.ghc8.6.yaml

26+ os: osx

27+ osx_image: xcode11

28+ compiler: ": #stack 8.6.5"

2929

3030before_script:

3131 - unset CC

@@ -43,13 +43,13 @@ script:

4343 stack --no-terminal --jobs=2 --system-ghc test

4444 - |

4545 #Run HLint

46− if [[ "$(uname)" = "Linux" ]]; then

46+ if [[ "$(uname)" = "Linux" ]]; then

4747 curl -sL https://raw.github.com/ndmitchell/hlint/master/misc/travis.sh | sh -s lint src test examples --cpp-define VERSION_project_m36=HLINT

4848 fi

4949 - |

5050 #Run Haddock

51− if [[ "$(uname)" = "Linux" ]]; then

52− stack --no-install-ghc --system-ghc --no-haddock-deps haddock

51+ if [[ "$(uname)" = "Linux" ]]; then

52+ stack --no-install-ghc --system-ghc --no-haddock-deps haddock

5353 fi

5454

5555after_success:

.travis/install-stack.sh+2−2

@@ -10,11 +10,11 @@ travis_retry() {

1010}

1111

1212fetch_stack_osx() {

13− curl -skL https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin;

13+ curl -skL https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin;

1414}

1515

1616fetch_stack_linux() {

17− curl -sL https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack';

17+ curl -sL https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack';

1818}

1919

2020# We need stack to generate cabal files with precise bounds, even for cabal

Changelog.markdown+8

@@ -1,3 +1,11 @@

1+# 2019-09-07 (v0.7)

3+* fix case sensitivity issue with relation variables in tutd

4+* fix multibyte escaping in data frames

5+* fix broken instances of `Atomable [a]`

6+* fix `TypeConstructor` validation of argument count

7+* add help option to executables

19# 2019-01-08 (v0.6)

210

311* fix atom type parsing to support more complex data types

README.markdown+2−1

@@ -48,6 +48,7 @@ Project:M36 supports multiple frontends which target different audiences.

4848

49491. [Installation and Introduction to Project:M36](docs/introduction_to_projectm36.markdown)

50501. [Introduction to the Relational Algebra](docs/introduction_to_the_relational_algebra.markdown)

51+1. [TutorialD Cheatsheet](docs/tutd_cheatsheet.markdown)

51521. [TutorialD via Jupyter Notebook Walkthrough](jupyter/TutorialD%20Notebook%20Walkthrough.ipynb)

52531. [TutorialD Tutorial](docs/tutd_tutorial.markdown)

53541. [15 Minute Tutorial](docs/15_minute_tutorial.markdown)

@@ -85,7 +86,7 @@ Project:M36 supports multiple frontends which target different audiences.

8586

8687## Development

8788

88−Project:M36 is developed in Haskell and compiled with GHC 8.0.2 or later.

89+Project:M36 is developed in Haskell and compiled with GHC 8.2.2 or later.

8990

9091## Related Projects

9192

cabal.project+3−3

@@ -1,9 +1,9 @@

11-- this is needed for GHC8 until distributed-process-extras is updated on Hackage with increased upper bounds

22packages: project-m36.cabal

3−allow-newer: distributed-process-extras:time,distributed-process-extras:binary,distributed-process-client-server:binary,distributed-process-client-server:time,distributed-process-async:time,distributed-process-async:binary,distributed-process-extras:stm,distributed-process-extras:containers,network-transport-tcp:containers,distributed-process-client-server:stm,distributed-process-client-server:containers,distributed-process-async:stm,distributed-process-async:containers

3+allow-newer: distributed-process-extras:time,distributed-process-extras:binary,distributed-process-client-server:binary,distributed-process-client-server:time,distributed-process-async:time,distributed-process-async:binary,distributed-process-extras:stm,distributed-process-extras:containers,network-transport-tcp:containers,distributed-process-client-server:stm,distributed-process-client-server:containers,distributed-process-async:stm,distributed-process-async:containers,distributed-process:hashable,distributed-process-extras:hashable,distributed-process-client-server:hashable,distributed-process-async:hashable

55--necessary for GHC 8.6 support :/

66source-repository-package

77 type: git

8− location: https://github.com/haskell-distributed/distributed-process.git

9− tag: 660d554f6acd2dba8b605c84e8fa69e45708bc14

8+ location: https://github.com/agentm/distributed-process.git

9+ tag: f352e097fbe494ad648b4e09249f865893ae90a3

docs/15_minute_tutorial.markdown+2−2

@@ -5,7 +5,7 @@ Thank you for evaluating Project:M36, a new relational algebra engine written in

55## Prerequisites

77* any Linux

8−* GHC 7.10 or later version (Haskell compiler)

8+* GHC 8.2 or later version (Haskell compiler)

99* cabal (package downloader) installed

1010

1111## Download and Install

@@ -19,7 +19,7 @@ cabal run tutd

1919

2020## Some Basic TutorialD

2121

22−When you run the ```tutd``` interpreter, you are interacting with an in-memory database using a dialect of the TutorialD language which is described in numerous book by Chris J. Date. It is a language specifically designed for human interaction with the relational algebra.

22+When you run the ```tutd``` interpreter, you are interacting with an in-memory database using a dialect of the TutorialD language which is described in numerous books by Chris J. Date. It is a language specifically designed for human interaction with the relational algebra.

2323

2424Note that TutorialD is strongly-typed- no type coercions take place automatically. For example, an integer will never be interpreted as a string or vice versa.

2525

docs/commits_in_constant_time.markdownnew file+134

@@ -0,0 +1,134 @@

1+# Transactional Database Commits in O(1)

3+A.M.

5+[Project:M36](https://github.com/agentm/project-m36)

7+## Synopsis

9+Common relational database management systems operate in an imperative manner by executing statements immediately. This naive strategy quickly becomes an IO-bound bottleneck. By applying Haskell's laziness-in-evaluation to database updates, new doors for optimizations based on what is queried make themselves apparent. Furthermore, by serializing thunks representing idempotent database updates, the database can commit transactions in constant time with regards to the tuple count since the tuples themselves need not be serialized. This optimization, combined with *fsync*-coalescing, can allow databases to commit to disk faster than tuples updates can be processed.

10+

11+Using this deferred execution technique, database updates can be processed in the background or, in the case when the tuples are never requested, never.

12+

13+These database update thunks and other interesting optimizations are implemented in [Project:M36](https://github.com/agentm/project-m36): an experimental, clean-room, purely Haskell implementation of an RDBMS engine based on the mathematical principles of the relational algebra.

14+

15+## Rationale

16+

17+A typical SQL RDBMS such as PostgreSQL executes a list of commands serially against a serializable representation of the database state without concern to whether or not the commands are effectively necessary to service subsequent requests. A database update which affects *n* tuples will necessitate disk writes of *O(n)* plus *O(n\*log(n))* writes for each affected index.

18+

19+By validating and serializing thunks of validated commands, Project:M36 commits can be independent of the tuple write cost. The thunks, which are flushed to non-volatile storage to complete the transaction commit, allow the DBMS to defer execution in preference to commit time.

20+

21+The deferral is, however, not required, and could be left as a option to the user or application.

22+

23+The final cost of committing in Project:M36 relates to the size of the update expression. If the update expression is, for example, a insertion of a large number of rows, then the commit cost will be *O(t)* where *t* is the number of tuples expressed in the update, but still independent of the cost of the existing tuples in the database.

24+

25+## Example and Comparison to PostgreSQL

26+

27+Let us walk through a specific example using SQL. While Project:M36 does not support SQL (and for [good reasons](https://github.com/agentm/project-m36/blob/master/docs/on_null.markdown)), comparing both databases with a common language is useful for illustrative purposes.

28+

29+Let us consider an existing database with a table/relation named "BigTable" which has 10 billion rows/tuples (an arbitrarily large number) of which one column is named "x" and represents a randomly-assigned integer. Next, assume that the user of the database will execute an update which will update every row/tuple, commit the changes, then query a subset of the resultant updated rows/tuples.

30+

31+

32+### The Update Expression

33+

34+Consider the following database update:

35+

36+```

37+UPDATE "BigTable" SET x = x + 1;

38+```

39+In PostgreSQL, the cost of executing this expression is incurred immediately upon execution. New tuples are laid down to disk (if the dataset is larger than *shared_buffers*), duplicating the entirety of the existing table/relation in storage (due to MVCC) for a cost of *O(n)* where *n* is the number of existing rows/tuples in "BigTable". If *x* is indexed, then the index writes incur an additional cost of *O(n\*log(n))* writes. Furthermore, PostgreSQL will write all changes to its write-ahead log, so the cost is multiplied by some factor.

40+

41+In Project:M36, the same expression can first be statically validated to adhere to the database constraints. The only constraint affected here is for the column/attribute *x* which requires an integer. Since adding one to any integer retains the integer type, the constraint can be determined to be unviolated without evaluating the expression, thus at a cost of *O(1)*. Project:M36 uses a novel WORM (write-once, read-many) strategy over journaled filesystems to avoid the need for a separate journal.

42+

43+*For the purpose of this example, assume that integer overflow is not a concern.*

44+

45+### The Commit

46+

47+```

48+COMMIT;

49+```

50+

51+In PostgreSQL, the write-ahead log mentioned above containing all tuples changes must now be flushed to non-volatile storage, creating a bottleneck to the slowest form of storage. A necessary checkpoint (which is configurable) could incur further writes as the tuples are flushed to disk as well.

52+

53+In Project:M36, the update expression must also be flushed to disk, but the expression is a mere few bytes appended to the transaction graph.

54+

55+### The Subsequent Query

56+

57+Finally, the user queries a subset of the updated table/relation.

58+

59+```

60+SELECT a, b, c, x FROM "BigTable" WHERE x > 10000;

61+```

62+

63+In PostgreSQL, considering that the column/attribute has an index, *O(log(n))* reads are needed to identify on which pages in the table's on-disk storage the proper values can be found. Considering that the value *x* was previously described as random, despite the restriction, in the worst case, every page of the on-disk table may need to be read because each page could contain one value matching the restriction. This would necessitate reading *O(n)* tuples previously written to disk. After reading the tuples, the tuples must be filtered by the restriction to service the query.

64+

65+In Project:M36, the state of the database is determined to be the difference of the previous state *S* (before the *x+1* update above) and *S'* (after the update). The serialized update expression can be deserialized and merged into the rewritten query:

66+

67+```

68+SELECT orig.a, orig.b, orig.c, x_orig + 1 AS x FROM (SELECT a, b, c, x AS x_orig FROM "BigTable"@S) AS orig WHERE x > 10000;

69+```

70+

71+where the *@* symbol references the state of "BigTable" at transaction state *S* in the past. The rewrite process can occur in constant time regarding the tuple count, but the execution does require reading the previous state *S* of "BigTable", filtering it as expected. The tuple read cost is equivalent to that of the same statement at *S'*: *O(log(n))* utilizing a b-tree index.

72+

73+### Summary

74+

75+| | PostgreSQL | Project:M36 |

76+|-|------------|-------------|

77+| UPDATE x+1 | *O(nlog(n))* | *O(1)* |

78+| COMMIT | flush *n* tuples to disk | flush expression to disk |

79+| SELECT x>10000 | *Ω(log(n))*, *O(n)* worst case | *O(log(n))* |

80+

81+Even if the user were to query all the tuples back, the actual IO cost in Project:M36 would be lower since the updates are only "executed" on the fly and not necessarily written to disk. However, a clever cacheing strategy could note that state *S* is queried often enough to warrant a cached version. The table's data on disk, however, is not required to answer the query.

82+

83+## Constraint Oracles

84+

85+To be able to perform an update and commit in constant or less than *O(n)* time does have some preconditions:

86+

87+ * constraints must be able to be statically validated in linear or logarithmic time

88+

89+However, even if constraints lack a proper oracle such as an index or a static means of validation and, thus, cannot be validated in constant time, the user may still benefit from serialization of the database update expression since writing the validated tuples to disk can be deferred beyond commit time and could go directly into an on-disk cache.

90+

91+## Worst Case Behavior

92+

93+Every database constraint can be represented as an inclusion dependency whereby the evaluation of a relational expression `sub` must be a subset of the evaluation of relational expression `super` (`sub ⊆ super`) for the constraint to validate. Therefore, the worst case time to validate any constraint, assuming that the constraint has an ideal oracle, is O(n) in the tuple count. However, as mentioned above, there are many constraints that can be validated in constant or less-than-linear time. Furthermore, the validated tuples need not be written to disk once the constraint is found to hold.

94+

95+Since there is great variation in constraint validation cost, the RDBMS could pre-analyze and report on associated constraints costs or make use of data independence to guide storage to optimize queries needed to service the constraint checker.

96+

97+## Caveats

98+

99+Certain types of updates still take a similar amount of time to commit in Project:M36 in comparison to PostgreSQL. Specifically, any update which relies on data outside the database's purview will necessitate flushing the tuple data since the update expression contains new tuple data not based on existing tuples. For example, the equivalent of:

100+

101+```

102+INSERT INTO "BigTable"(a, b, c, x) VALUES (1,5,10,10),(20,20,21,30),.... #many tuples

103+```

104+will still necessitate a *O(n)* tuple writes to disk in both databases. Though the asymptotic costs are equivalent, the number of writes are cut in half in Project:M36 since it does not require a write-ahead log.

105+

106+While PostgreSQL makes use of MVCC (multi-version concurrency control) which marks which tuples belong to a linear progression of transaction states, Project:M36 stores a full history of database state using a transaction graph (a directed acyclic graph similar to the commit-based graph of `git`). The graph allows named branches to be created and merged which also reduce contention around a singular graph head.

107+

108+## Applying Laziness to SQL RDBMSes

109+

110+Would it be possible to apply transaction-based laziness to an SQL-based RDBMS? Certainly, with sufficient shoe-horning, it could work, but SQL includes a few malfeatures which would make it difficult, if not impossible:

111+

112+ * Non-idempotent server-side functions prevent laziness because of side effects. PostgreSQL can mark functions as idempotent, but does not validate or enforce the idempotence, Project:M36, via Safe Haskell, can validate pure functions.

113+ * The lack of "time travel", the ability to query database state in the past prevents reliance on previous states, prevents direct referencing of previous database states on which the state differences can be built.

114+ * Tightly-coupled table-to-storage management prevents alternative data models. Indexing and constraint checking need to be statically verifiable and deferrable.

115+

116+These hurdles are not insurmountable, just perhaps not a good fit for SQL databases with a lot of historical and implementation baggage.

117+

118+## Benchmarks

119+

120+Forthcoming.

121+

122+## Conclusion

123+

124+Transactional time-to-commit is critical in ensuring that business decisions can make it to non-volatile storage as quickly as possible. By introducing Haskell-like, lazy evaluation to update expressions and serializing the resultant thunk, commits can be serialized in constant time, disregarding the number of tuples modified in the expression.

125+

126+This serialization strategy turns modern RDBMS architecture on its head since the table/relation-to-file mapping is broken, resulting in true data independence. Any on-disk representation of a relation at a specific transaction state therefore merely becomes a cached and purgeable entity, drastically shrinking on-disk cacheing requirements while expanding the scope in which said strategies can operate. Hopefully, a truly data independent architecture will result in new optimization discoveries.

127+

128+Project:M36 implements a transaction graph which can represent the entirety of database state, leaving room for any number of alternative representations, even for a single relation or relation across transaction states. A simple example could include storing two different orderings of tuples of the same relation in order to optimally serve different join queries. Common RDBMSes offer only two on-disk representations: the set of fully-evaluated tuples and indexes to those tuples, preventing data independence. Data independence paves the way towards the elimination of implementation-specific, gatekeeper roles such as database administrators.

129+

130+The promise of the relational algebra has always been the liberation of data from its data structure representation in order to be able to answer arbitrary queries. Modern DBMSes which typically map tables directly to one or more files on disk fail to live up to this promise. Project:M36 sets out to rectify this failure.

131+

132+In a greater context, applying laziness to an architecture to make use of more interesting optimizations is hardly new. The OpenGL API views its "immediate" mode as effectively deprecated. Filesystems take advantage of laziness using copy-on-write semantics. High-level programming languages can make greater, more interesting inferences about how a computation must be execute. A computer can always consider many more possible solution paths than a human can.

133+

134+The adherence to mathematical priniciples in Project:M36 results in features and optimization opportunities which have not yet been discovered. In contrast to RDBMSes designed around specific optimizations (such as indexes, specific disk layouts, or key-value lookups), Project:M36 sets out to demonstrate practically that future optimizations can only be discovered when operating within a mathematically-coherent architecture.

docs/introduction_to_projectm36.markdown+3−3

@@ -32,7 +32,7 @@ Requirements:

3232

3333To build with stack:

3434

35−* [GHC 8.2.2 or greater](https://www.haskell.org/downloads)

35+* [GHC 8.4.4 or greater](https://www.haskell.org/downloads)

3636* [Haskell stack](https://docs.haskellstack.org/en/stable/README/)

3737* Linux, macOS, or Microsoft Windows

3838

@@ -40,11 +40,11 @@ Compilation steps:

4040

4141* ```git clone https://github.com/agentm/project-m36```

4242* ```cd project-m36```

43−* ```stack --stack-yaml stack.ghc8.2.yaml build```

43+* ```stack --stack-yaml stack.ghc8.6.yaml build```

4444

4545At this point, the TutorialD interactive interpreter can be run using ```stack exec tutd```.

4646

47−Alternative building with GHC 8.0.2 or greater:

47+Alternative building with GHC 8.4.4 or greater:

4848

4949* ```cabal new-build```

5050

docs/server_mode.markdown+1−1

@@ -8,7 +8,7 @@ While Project:M36 is easy-to-use as an interactive, in-process database manageme

99To start the Project:M36 server to serve the local host with a database named "mydbname", run ```cabal run project-m36-server -- --database mydbname --hostname 127.0.0.1``` in the project-m36 source directory. The double-dash indicates that the arguments should be passed to ```project-m36-server``` instead of ```cabal```. Under normal conditions, this command will print nothing and block indefinitely to serve incoming requests on the default port 6543.

1010

11−Note that the above invocation will serve and in-memory, transient "mydbname" database. The database is deleted when the server exits. To serve a database with filesystem persistence, invoke ```cabal run project-m36-server -- --database mydbname --hostname 127.0.0.1 --database-directory /path/to/dbdirectory --fsync```.

11+Note that the above invocation will serve an in-memory, transient "mydbname" database. The database is deleted when the server exits. To serve a database with filesystem persistence, invoke ```cabal run project-m36-server -- --database mydbname --hostname 127.0.0.1 --database-directory /path/to/dbdirectory --fsync```.

1212

1313## Connecting an Interactive Client

1414

docs/tutd_cheatsheet.markdownnew file+97

@@ -0,0 +1,97 @@

1+# Tutorial D Cheatsheet

3+The following tables list examples of expressions for `tutd`, Project:M36's "Tutorial D" implementation.

5+## Relational Expressions

7+Relational expressions query database state without being able to change it.

9+|Relational Expression |Description |

10+|------------------------------------------------------|---------------------------------------|

11+|`:showexpr p`|Display the relation variable `p`|

12+|`:showexpr s rename {city as town}`|Display the result after renaming a relational attribute|

13+|`:showexpr p{color,city}`|Display the result of the projection on the `color` and `city` attributes|

14+|`:showexpr p{all but city}`|Display the result of the projection of all attribute of `p` except `city`|

15+|`:showexpr p join sp`|Display the result of the relational expression `p` joined against `sp` (equivalent to `NATURAL JOIN` in SQL)|

16+|`:showexpr (s join sp){all from s}`|Display the result of a join but only include attributes from `s`|

17+|`:showexpr s semijoin sp`|Equivalent to `(s join sp){all from s}`|

18+|`:showexpr s antijoin sp`|Display the result of all tuples in `s` which do not match appear in the result of `s semijoin sp`|

19+|`:showexpr s union s`| Display the result of `s` unioned with itself (which is equivalent to `s`)|

20+|`:showexpr s:{status2:=add(10,@status)}`| Display the result of extending the `s` relation variable with a new attribute which adds 10 to each `status` attribute|

21+|`:showexpr s group ({sname,status,s#} as subrel)`| Display the result of grouping the `sname`, `status`, and `s#` into a subrel for each tuple in the `s` relation where the `city` attribute (not mentioned) is the grouping criteria|

22+|`:showexpr (s group ({sname,status,s#} as subrel)) ungroup subrel`| Display the result of unwrapping a subrelation to create one new tuple for each subrelation tuple in the result|

23+|`:showexpr s minus s`|Display the result after removing all tuples that match the second argument. `x minus x` is equivalent to `x where false`|

24+|`:showexpr relation{tuple{name "Mike",age 6},tuple{name "Sam",age 10}}`|Display an unnamed relation using manually constructed tuples|

25+|`:showexpr relation{a Integer, b Text}`|Display an empty-tupled relation of a specified type|

26+|`:showexpr relation{a Integer, b Text}{tuple{a 4, b "four"}}`|Display a relation bound by the specified types and containing one or more tuples|

27+|`:showexpr s group ({s#,sname,status} as subrel):{citycount:=count(@subrel)}`|Display a result which groups `s` by `city` and extends the relation by a count for each city.|

28+|`:showrelvars`|Display a list of relation variables in the current context along with their types (attributes)|

29+

30+## Built-In Types

31+

32+|Example Value Expression |Type |Explanation|

33+|------------------------------------------------------|---------------------------------------|-----------|

34+|`"abc"`|Text|UTF-8 string|

35+|`123`|Integer|an integer of limitless size (using gmp)|

36+|`int(456)`|Int|machine-word-based integer|

37+|`12.56`|Double|64-bit IEEE 754 floating point number|

38+|`dateTimeFromEpochSeconds(1502304846)`|DateTime||

39+|`fromGregorian(2017,05,30)`|Date||

40+|`t`|Bool|`t` or `f`|

41+|`bytestring("dGVzdGRhdGE=")`|Bytestring|base-64-encoded string of bytes|

42+|`interval(3,5,f,f)`|Interval(Integer)|the constructor function includes two bounds and two boolean flags for inclusiveness|

43+

44+## Database Context Expressions

45+

46+Database context expressions take the current database context as input and alter it to create a new

47+

48+|Database Context Expression |Description |

49+|------------------------------------------------------|---------------------------------------|

50+|`:importexample date`|Imports a precooked schema from Chris Date's books resulting in relvars `s`, `sp`, and `p`|

51+|`newrelvar:=relation{tuple{age 3}}`|Assign a new relation variable named `newrelvar`|

52+|`undefine s`|Remove a relation variable|

53+|`insert s relation{tuple{city "Boston",s# "S10",sname "Gonzalez",status 10}}`| Append to an existing relation variable with another relational expression|

54+|`update s where status=20 (sname:="Mr. Twenty")`|Replace one or more values in matching tuples with a new value|

55+|`delete sp where s#="S4"`|Remove tuples matching the criteria|

56+|`key s_key_constraint {s#} s`|Add a constraint named `s_key_constraint` on relation variable `s` ensuring that `s#` is unique|

57+|`foreign key s#_in_sp sp{s#} in s{s#}`|Add a foreign key constraint that ensures that `sp`'s `s#` attribute always references a `s#` value in `s`|

58+|`constraint s_status_less_than_50 (s where ^lt(50,@status)){} in false`|Add a constraint that stipulates that the `status` values in `s` are less than 50|

59+|`createarbitraryrelation employee {name Text, empid Int, hired DateTime} 3-100`|Create a relation variable with random values with between 3-100 tuples- useful for testing|

60+|`notify steve_change person where name="Steve" true (person where name="Steve"){address}`|Notify the current connection with an asynchronous event if any committed tuples matching `person where name="Steve"` with `true` for the pre-change state and `person where name="Steve"){address}` for the post-change state- these states will be sent along with the notification|

62+|`undata Hair`|Delete the `Hair` custom type|

63+

64+

65+## Transaction Graph Expressions

66+

67+Transaction graph expressions alter the state of the transaction graph by append new states.

68+

69+|Transaction Graph Expression |Description |

70+|------------------------------------------------------|---------------------------------------|

71+|`:commit`|Save the current database context to a new transaction and add it to the transaction graph|

72+|`:rollback`|Return the database context to the state before any alterations were made|

73+|`:branch experimental`|Create a new branch from the existing branch and switch the current context to be able to commit to the new branch|

74+|`:jumphead master`|Discard any changes in the current context and jump to the head of a different branch|

75+|`:jump 11b601c9-f46b-42b0-a2ce-cf18ced31b7f`|Jump to the specific transaction by UUID- useful for introspecting past states|

76+|`:showgraph`|Display a representation of the transaction graph|

77+|`:walkbacktotime "2017-08-10 16:44:00"`|Walk back in time from the current branch until a transaction less than or equal to the time is found and switch the current context to that past transaction- useful for auditing|

78+

79+## Data Frame Expressions

80+

81+In contrast to relational expressions, data frame expressions generate ordered tuples.

82+

83+|Data Frame Expression |Description |

84+|------------------------------------------------------|---------------------------------------|

85+|`:showdataframe s orderby {status}`|Display a data frame result for the relational expression `s` and sort the tuples by `status`|

86+|`:showdataframe s{status} orderby {status descending} offset 1 limit 3`|Display a data frame result for `s{status}` but ordered by `status` values descending, skip the first tuple, and return no more than 3 tuples|

87+

88+## Trans-Graph Relational Expressions

89+

90+Trans-graph relational expressions allow queries spanning multiple transactions.

91+

92+|Trans-Graph Relational Expressions |Description |

93+|------------------------------------------------------|---------------------------------------|

94+|`:showtransgraphexpr s@master join sp@master`|Display a result for joining `s` and `sp` on the branch `master`|

95+|`:showtransgraphexpr s@master~ join sp@master`|Display a result for joining `s` on the parent transaction of `master`'s current head and `sp` on master|

96+|`:showtransgraphexpr s@master~^2`|Display a result for `s` two parents previous to the parent of the current `master`'s head|

97+

docs/websocket_server.markdown+2−2

@@ -16,8 +16,8 @@ except that the websocket server is now listening for websocket connections on p

1616

1717## Client Connection

1818

19−A [simple JavaScript library](/ProjectM36/Server/WebSocket/project-m36.js) to manage the WebSocket connection is available.

19+A [simple JavaScript library](/src/bin/ProjectM36/Server/WebSocket/project-m36.js) to manage the WebSocket connection is available.

2020

2121## Sample Application

2222

23−The [WebSocket example application](/ProjectM36/Server/WebSocket/websocket-client.html) can be used to learn TutorialD and for remote database access from the web browser.

23+The [WebSocket example application](/src/bin/ProjectM36/Server/WebSocket/websocket-client.html) can be used to learn TutorialD and for remote database access from the web browser.

examples/blog.hs+1−1

@@ -17,7 +17,7 @@ import Data.Time.Clock

1717import Data.Time.Calendar

1818import Control.DeepSeq

1919import Data.Proxy

20−#if __GLASGOW_HASKELL__ <= 802

20+#if __GLASGOW_HASKELL__ < 804

2121import Data.Monoid

2222#endif

2323import Data.List

project-m36.cabal+34−10

@@ -28,8 +28,19 @@ Flag stack

2828 Manual: True

2929 Default: False

3030

31+Flag haskell-scripting

32+ Description: enables Haskell scripting which links against GHC as a library

33+ Manual: True

34+ Default: True

35+

3136Library

32− Build-Depends: base>=4.8 && < 4.13, ghc >= 8.2 && < 8.7, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256

37+ Build-Depends: base>=4.8 && < 4.14, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256

38+ if flag(haskell-scripting)

39+ Build-Depends: ghc >= 8.2 && < 8.9

40+ CPP-Options: -DPM36_HASKELL_SCRIPTING

41+ if impl(ghc>= 8) && flag(haskell-scripting)

42+ build-depends:

43+ ghc-boot, ghci

3344 if impl(ghc>= 8.6)

3445 Build-Depends: deferred-folds

3546 Exposed-Modules: ProjectM36.Error,

@@ -118,19 +129,17 @@ Library

118129 GHC-Options: -rdynamic

119130 C-sources: cbits/DirectoryFsync.c, cbits/darwin_statfs.c

120131 Build-Depends: unix

121− CC-Options: -fPIC

132+ CC-Options: -fPIC

122133 Hs-Source-Dirs: ./src/lib

123134 Default-Language: Haskell2010

124135 Default-Extensions: OverloadedStrings, CPP

125− if impl(ghc>= 8)

126− build-depends:

127− ghc-boot, ghci

128136 if !flag(stack)

129137 Build-Depends: deferred-folds

130138

131139Executable tutd

140+ if flag(haskell-scripting)

141+ Build-Depends: ghc >= 8.2 && < 8.9

132142 Build-Depends: base >=4.8 && <5.0,

133− ghc >= 7.8 && < 8.7,

134143 ghc-paths,

135144 project-m36,

136145 containers,

@@ -158,7 +167,7 @@ Executable tutd

158167 directory,

159168 filepath,

160169 temporary,

161− megaparsec >= 5.2.0 && < 8,

170+ megaparsec >= 5.2.0 && < 9,

162171 haskeline,

163172 random, MonadRandom,

164173 base64-bytestring,

@@ -193,8 +202,9 @@ Executable tutd

193202 Default-Extensions: OverloadedStrings

194203

195204Executable project-m36-server

205+ if flag(haskell-scripting)

206+ Build-Depends: ghc >= 8.2 && < 8.9

196207 Build-Depends: base,

197− ghc >= 7.8 && < 8.7,

198208 ghc-paths,

199209 project-m36,

200210 binary,

@@ -224,12 +234,26 @@ Executable project-m36-server

224234 list-t,

225235 base64-bytestring

226236 Main-Is: ./src/bin/ProjectM36/Server/project-m36-server.hs

227− GHC-Options: -Wall -threaded -rtsopts

237+ GHC-Options: -Wall -threaded -rtsopts

228238 if flag(profiler)

229239 GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall

230240 Default-Language: Haskell2010

231241 Default-Extensions: OverloadedStrings

232242

243+Executable bigrel

244+ Default-Language: Haskell2010

245+ Default-Extensions: OverloadedStrings

246+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators

247+ Other-Modules: TutorialD.Interpreter.Base,

248+ TutorialD.Interpreter.DatabaseContextExpr,

249+ TutorialD.Interpreter.RelationalExpr,

250+ TutorialD.Interpreter.Types

251+ main-is: benchmark/bigrel.hs

252+ GHC-Options: -Wall -threaded -rtsopts

253+ HS-Source-Dirs: ./src/bin

254+ if flag(profiler)

255+ GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall

256+

233257Benchmark basic-benchmark

234258 Default-Language: Haskell2010

235259 Default-Extensions: OverloadedStrings

@@ -497,7 +521,7 @@ Executable handles

497521 HS-Source-Dirs: ./src/bin

498522 if flag(profiler)

499523 GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall

500−

524+

501525Test-Suite test-dataframe

502526 Default-Language: Haskell2010

503527 Main-Is: test/DataFrame.hs

src/bin/ProjectM36/Server/WebSocket.hs+17−17

@@ -28,7 +28,7 @@ import Data.List.NonEmpty as NE

2828#endif

2929

3030websocketProxyServer :: Port -> Hostname -> WS.ServerApp

31−websocketProxyServer port host pending = do

31+websocketProxyServer port host pending = do

3232 conn <- WS.acceptRequest pending

3333 let unexpectedMsg = WS.sendTextData conn ("messagenotexpected" :: T.Text)

3434 --phase 1- accept database name for connection

@@ -37,10 +37,10 @@ websocketProxyServer port host pending = do

3737 if not (connectdbmsg `T.isPrefixOf` dbmsg) then unexpectedMsg >> WS.sendClose conn ("" :: T.Text)

3838 else do

3939 let dbname = T.unpack $ T.drop (T.length connectdbmsg) dbmsg

40− bracket (createConnection conn dbname port host)

40+ bracket (createConnection conn dbname port host)

4141 (\case

4242 Right dbconn -> close dbconn

43− Left _ -> pure ()) $ \case

43+ Left _ -> pure ()) $ \case

4444 Left err -> sendError conn err

4545 Right dbconn -> do

4646 eSessionId <- createSessionAtHead dbconn "master"

@@ -51,7 +51,7 @@ websocketProxyServer port host pending = do

5151 _ <- forever $ do

5252 pInfo <- promptInfo sessionId dbconn

5353 --figure out why sending three times during startup is necessary

54− sendPromptInfo pInfo conn

54+ sendPromptInfo pInfo conn

5555 sendPromptInfo pInfo conn

5656 msg <- WS.receiveData conn :: IO T.Text

5757 case parseOnly parseExecuteMessage msg of

@@ -67,22 +67,22 @@ websocketProxyServer port host pending = do

6767 (DisplayErrorResult ("parse error: " `T.append` T.pack (parseErrorPretty err)))

6868#endif

6969 Right parsed -> do

70− let timeoutFilter exc = if exc == RequestTimeoutException

71− then Just exc

70+ let timeoutFilter exc = if exc == RequestTimeoutException

71+ then Just exc

7272 else Nothing

7373 responseHandler = do

7474 result <- evalTutorialD sessionId dbconn SafeEvaluation parsed

7575 pInfo' <- promptInfo sessionId dbconn

76− sendPromptInfo pInfo' conn

76+ sendPromptInfo pInfo' conn

7777 handleOpResult conn dbconn presentation result

7878 catchJust timeoutFilter responseHandler (\_ -> handleOpResult conn dbconn presentation (DisplayErrorResult "Request Timed Out."))

7979 pure ()

80−

81−notificationCallback :: WS.Connection -> NotificationCallback

80+

81+notificationCallback :: WS.Connection -> NotificationCallback

8282notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (object ["notificationname" .= notifName,

8383 "evaldnotification" .= evaldNotif

8484 ]))

85−

85+

8686--this creates a new database for each connection- perhaps not what we want (?)

8787createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (Either ConnectionError Connection)

8888createConnection wsconn dbname port host = connectProjectM36 (RemoteProcessConnectionInfo dbname (createNodeId host port) (notificationCallback wsconn))

@@ -111,32 +111,32 @@ handleOpResult conn _ presentation (DisplayDataFrameResult df) = do

111111 texto = ["text" .= showDataFrame df | textPresentation presentation]

112112 htmlo = ["html" .= dataFrameAsHTML df | htmlPresentation presentation]

113113 WS.sendTextData conn (encode (object ["displaydataframe" .= object (jsono ++ texto ++ htmlo)]))

114−

114+

115115-- get current schema and head name for client

116116promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName)

117117promptInfo sessionId conn = do

118− eHeadName <- headName sessionId conn

118+ eHeadName <- headName sessionId conn

119119 eSchemaName <- currentSchemaName sessionId conn

120120 pure (either (const "<unknown>") id eHeadName, either (const "<no schema>") id eSchemaName)

121−

121+

122122sendPromptInfo :: (HeadName, SchemaName) -> WS.Connection -> IO ()

123123sendPromptInfo (hName, sName) conn = WS.sendTextData conn (encode (object ["promptInfo" .= object ["headname" .= hName, "schemaname" .= sName]]))

124124

125125--a returning relation can be returned as JSON, Text (for consoles), or HTML

126126data Presentation = Presentation {

127− jsonPresentation :: Bool,

127+ jsonPresentation :: Bool,

128128 textPresentation :: Bool,

129129 htmlPresentation :: Bool }

130−

130+

131131data PresentationFlag = JSONFlag | TextFlag | HTMLFlag

132−

132+

133133parseExecuteMessage :: Parser (Presentation, T.Text)

134134parseExecuteMessage = do

135135 _ <- string "executetutd/"

136136 flags <- sepBy ((string "json" $> JSONFlag) <|>

137137 (string "text" $> TextFlag) <|>

138138 (string "html" $> HTMLFlag)) "+"

139− let presentation = foldr (\flag acc -> case flag of

139+ let presentation = foldr (\flag acc -> case flag of

140140 JSONFlag -> acc {jsonPresentation = True}

141141 TextFlag -> acc {textPresentation = True}

142142 HTMLFlag -> acc {htmlPresentation = True}) (Presentation False False False) flags

src/bin/TutorialD/Interpreter.hs+26−26

@@ -28,7 +28,7 @@ import System.Console.Haskeline

2828import System.Directory (getHomeDirectory)

2929import qualified Data.Text as T

3030import System.IO (hPutStrLn, stderr)

31−#if __GLASGOW_HASKELL__ <= 802

31+#if __GLASGOW_HASKELL__ < 804

3232import Data.Monoid

3333#endif

3434import Data.List (isPrefixOf)

@@ -61,7 +61,7 @@ interpreterParserP = safeInterpreterParserP <|>

6161 fmap ImportDBContextOp (tutdImportP <* eof) <|>

6262 fmap RelVarExportOp (exportCSVP <* eof) <|>

6363 fmap DatabaseContextIOExprOp (dbContextIOExprP <* eof)

64−

64+

6565-- the safe interpreter never reads or writes the file system

6666safeInterpreterParserP :: Parser ParsedOperation

6767safeInterpreterParserP = fmap RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>

@@ -78,7 +78,7 @@ promptText :: Either RelationalError HeadName -> Either RelationalError SchemaNa

7878promptText eHeadName eSchemaName = "TutorialD (" <> transInfo <> "): "

7979 where

8080 transInfo = either (const "<unknown>") id eHeadName <> "/" <> either (const "<no schema>") id eSchemaName

81−

81+

8282parseTutorialD :: T.Text -> Either ParserError ParsedOperation

8383parseTutorialD = parse interpreterParserP ""

8484

@@ -106,20 +106,20 @@ evalTutorialDInteractive sessionId conn safe interactive expr = case expr of

106106 else

107107 pure res

108108 _ -> pure res

109−

110− (DatabaseContextExprOp execOp) ->

111− eHandler $ C.executeDatabaseContextExpr sessionId conn execOp

112−

113− (DatabaseContextIOExprOp execOp) ->

109+

110+ (DatabaseContextExprOp execOp) ->

111+ eHandler $ C.executeDatabaseContextExpr sessionId conn execOp

112+

113+ (DatabaseContextIOExprOp execOp) ->

114114 if needsSafe then

115115 unsafeError

116116 else

117117 eHandler $ C.executeDatabaseContextIOExpr sessionId conn execOp

118−

118+

119119 (GraphOp execOp) -> do

120120 -- warn if the graph op could cause uncommited changes to be discarded

121121 eIsDirty <- C.disconnectedTransactionIsDirty sessionId conn

122− let runGraphOp = eHandler $ C.executeGraphExpr sessionId conn execOp

122+ let runGraphOp = eHandler $ C.executeGraphExpr sessionId conn execOp

123123 settings = Settings {complete = noCompletion,

124124 historyFile = Nothing,

125125 autoAddHistory = False}

@@ -143,20 +143,20 @@ evalTutorialDInteractive sessionId conn safe interactive expr = case expr of

143143 pure (DisplayErrorResult "Graph operation cancelled.")

144144 else

145145 runGraphOp

146−

146+

147147 (ConvenienceGraphOp execOp) ->

148148 eHandler $ evalConvenienceGraphOp sessionId conn execOp

149149

150150 (ROGraphOp execOp) -> do

151151 opResult <- evalROGraphOp sessionId conn execOp

152− case opResult of

152+ case opResult of

153153 Left err -> barf err

154154 Right rel -> pure (DisplayRelationResult rel)

155−

155+

156156 (SchemaOp execOp) ->

157157 eHandler $ evalSchemaOperator sessionId conn execOp

158−

159− (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) ->

158+

159+ (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) ->

160160 if needsSafe then

161161 unsafeError

162162 else do

@@ -174,8 +174,8 @@ evalTutorialDInteractive sessionId conn safe interactive expr = case expr of

174174 case exprErr of

175175 Left err -> barf err

176176 Right dbexpr -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexpr)

177−

178− (ImportDBContextOp execOp) ->

177+

178+ (ImportDBContextOp execOp) ->

179179 if needsSafe then

180180 unsafeError

181181 else do

@@ -183,15 +183,15 @@ evalTutorialDInteractive sessionId conn safe interactive expr = case expr of

183183 case eErr of

184184 Left err -> barf err

185185 Right dbexprs -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexprs)

186−

187− (InfoOp execOp) ->

186+

187+ (InfoOp execOp) ->

188188 if needsSafe then

189189 unsafeError

190190 else

191191 case evalInformationOperator execOp of

192192 Left err -> pure (DisplayErrorResult err)

193193 Right info -> pure (DisplayResult info)

194−

194+

195195 (RelVarExportOp execOp@(RelVarDataExportOperator relExpr _ _)) ->

196196 --eval relexpr to relation and pass to export function

197197 if needsSafe then

@@ -221,11 +221,11 @@ evalTutorialDInteractive sessionId conn safe interactive expr = case expr of

221221 case eErr of

222222 Left err -> barf err

223223 Right () -> return QuietSuccessResult

224−

225−type GhcPkgPath = String

224+

225+type GhcPkgPath = String

226226type TutorialDExec = String

227227type CheckFS = Bool

228−

228+

229229data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName (Maybe TutorialDExec) [GhcPkgPath] CheckFS |

230230 RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName (Maybe TutorialDExec) CheckFS

231231

@@ -256,12 +256,12 @@ reprLoop config sessionId conn = do

256256 Just line -> do

257257 runTutorialD sessionId conn (Just (T.length prompt)) (T.pack line)

258258 reprLoop config sessionId conn

259−

259+

260260

261261runTutorialD :: C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO ()

262−runTutorialD sessionId conn mPromptLength tutd =

262+runTutorialD sessionId conn mPromptLength tutd =

263263 case parseTutorialD tutd of

264− Left err ->

264+ Left err ->

265265 displayOpResult $ DisplayParseErrorResult mPromptLength err

266266 Right parsed ->

267267 catchJust (\exc -> if exc == C.RequestTimeoutException then Just exc else Nothing) (do

src/bin/TutorialD/Interpreter/Base.hs+23−28

@@ -1,8 +1,8 @@

11{-# LANGUAGE DeriveGeneric, CPP #-}

22module TutorialD.Interpreter.Base (

3− module TutorialD.Interpreter.Base,

3+ module TutorialD.Interpreter.Base,

44 module Text.Megaparsec,

5−#if MIN_VERSION_megaparsec(6,0,0)

5+#if MIN_VERSION_megaparsec(6,0,0)

66 module Text.Megaparsec.Char,

77 module Control.Applicative

88#else

@@ -35,7 +35,7 @@ import qualified Data.Text.IO as TIO

3535import System.IO

3636import ProjectM36.Relation.Show.Term

3737import GHC.Generics

38−#if __GLASGOW_HASKELL__ <= 802

38+#if __GLASGOW_HASKELL__ < 804

3939import Data.Monoid

4040#endif

4141import qualified Data.UUID as U

@@ -54,7 +54,7 @@ displayOpResult :: TutorialDOperatorResult -> IO ()

5454displayOpResult QuitResult = return ()

5555displayOpResult (DisplayResult out) = TIO.putStrLn out

5656displayOpResult (DisplayIOResult ioout) = ioout

57−displayOpResult (DisplayErrorResult err) = let outputf = if T.length err > 0 && T.last err /= '\n' then TIO.hPutStrLn else TIO.hPutStr in

57+displayOpResult (DisplayErrorResult err) = let outputf = if T.length err > 0 && T.last err /= '\n' then TIO.hPutStrLn else TIO.hPutStr in

5858 outputf stderr ("ERR: " <> err)

5959displayOpResult QuietSuccessResult = return ()

6060displayOpResult (DisplayRelationResult rel) = do

@@ -83,7 +83,7 @@ type ParseStr = String

8383

8484spaceConsumer :: Parser ()

8585spaceConsumer = Lex.space (void spaceChar) (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}")

86−

86+

8787opChar :: Parser Char

8888opChar = oneOf (":!#$%&*+./<=>?\\^|-~" :: String)-- remove "@" so it can be used as attribute marker without spaces

8989

@@ -102,9 +102,13 @@ braces = between (symbol "{") (symbol "}")

102102identifier :: Parser Text

103103identifier = do

104104 istart <- letterChar <|> char '_'

105− irest <- many (alphaNumChar <|> char '_' <|> char '#')

105+ identifierRemainder istart

106+

107+identifierRemainder :: Char -> Parser Text

108+identifierRemainder c = do

109+ rest <- many (alphaNumChar <|> char '_' <|> char '#')

106110 spaceConsumer

107− pure (pack (istart:irest))

111+ pure (pack (c:rest))

108112

109113symbol :: ParseStr -> Parser Text

110114#if MIN_VERSION_megaparsec(6,0,0)

@@ -149,20 +153,12 @@ float :: Parser Double

149153float = Lex.float

150154

151155capitalizedIdentifier :: Parser Text

152−capitalizedIdentifier = do

153− fletter <- upperChar

154− restOfIdentifier_ fletter

155−

156−restOfIdentifier_ :: Char -> Parser Text

157−restOfIdentifier_ fletter = do

158− rest <- option "" identifier

159− spaceConsumer

160− pure (T.cons fletter rest)

161−

156+capitalizedIdentifier =

157+ upperChar >>= identifierRemainder

158+

162159uncapitalizedIdentifier :: Parser Text

163−uncapitalizedIdentifier = do

164− fletter <- lowerChar

165− restOfIdentifier_ fletter

160+uncapitalizedIdentifier =

161+ lowerChar >>= identifierRemainder

166162

167163showRelationAttributes :: Attributes -> Text

168164showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ L.map showAttribute attrsL) <> "}"

@@ -170,14 +166,14 @@ showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ L.map showA

170166 showAttribute (Attribute name atomType) = name <> " " <> prettyAtomType atomType

171167 attrsL = V.toList attrs

172168

173−type PromptLength = Int

169+type PromptLength = Int

174170

175171#if MIN_VERSION_megaparsec(7,0,0)

176−type ParserError = ParseErrorBundle Text Void

172+type ParserError = ParseErrorBundle T.Text Void

177173#elif MIN_VERSION_megaparsec(6,0,0)

178174type ParserError = ParseError Char Void

179−#else

180−type ParserError = ParseError Char Dec

175+#else

176+type ParserError = ParseError Char Dec

181177#endif

182178

183179data TutorialDOperatorResult = QuitResult |

@@ -189,7 +185,7 @@ data TutorialDOperatorResult = QuitResult |

189185 DisplayParseErrorResult (Maybe PromptLength) ParserError | -- PromptLength refers to length of prompt text

190186 QuietSuccessResult

191187 deriving (Generic)

192−

188+

193189type TransactionGraphWasUpdated = Bool

194190

195191--allow for python-style triple quoting because guessing the correct amount of escapes in different contexts is annoying

@@ -197,7 +193,7 @@ tripleQuotedString :: Parser Text

197193tripleQuotedString = do

198194 _ <- tripleQuote

199195 pack <$> manyTill anySingle (try (tripleQuote >> notFollowedBy quote))

200−

196+

201197normalQuotedString :: Parser Text

202198normalQuotedString = quote *> (T.pack <$> manyTill Lex.charLiteral quote)

203199

@@ -206,7 +202,7 @@ quotedString = try tripleQuotedString <|> normalQuotedString

206202

207203uuidP :: Parser U.UUID

208204uuidP = do

209− uuidStart <- count 8 hexDigitChar

205+ uuidStart <- count 8 hexDigitChar

210206 _ <- char '-' -- min 28 with no dashes, maximum 4 dashes

211207 uuidMid1 <- count 4 hexDigitChar

212208 _ <- char '-'

@@ -226,4 +222,3 @@ utcTimeP = do

226222 case parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" (T.unpack timeStr) of

227223 Nothing -> fail "invalid datetime input, use \"YYYY-MM-DD HH:MM:SS\""

228224 Just stamp' -> pure stamp'

229−

src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+12−9

@@ -12,7 +12,7 @@ import ProjectM36.Error

1212import qualified ProjectM36.RelationalExpression as RE

1313import ProjectM36.Key

1414import ProjectM36.FunctionalDependency

15−#if __GLASGOW_HASKELL__ <= 802

15+#if __GLASGOW_HASKELL__ < 804

1616import Data.Monoid

1717#endif

1818import Data.Functor

@@ -44,7 +44,7 @@ nothingP = spaceConsumer >> pure NoOperation

4444assignP :: Parser DatabaseContextExpr

4545assignP = do

4646 relVarName <- try $ do

47− relVarName <- identifier

47+ relVarName <- relVarNameP

4848 reservedOp ":="

4949 return relVarName

5050 Assign relVarName <$> relExprP

@@ -59,13 +59,13 @@ multipleDatabaseContextExprP =

5959insertP :: Parser DatabaseContextExpr

6060insertP = do

6161 reservedOp "insert"

62− relvar <- identifier

62+ relvar <- relVarNameP

6363 Insert relvar <$> relExprP

6464

6565defineP :: Parser DatabaseContextExpr

6666defineP = do

6767 relVarName <- try $ do

68− relVarName <- identifier

68+ relVarName <- relVarNameP

6969 reservedOp "::"

7070 return relVarName

7171 Define relVarName <$> makeAttributeExprsP

@@ -73,17 +73,17 @@ defineP = do

7373undefineP :: Parser DatabaseContextExpr

7474undefineP = do

7575 reservedOp "undefine"

76− Undefine <$> identifier

76+ Undefine <$> relVarNameP

7777

7878deleteP :: Parser DatabaseContextExpr

7979deleteP = do

8080 reservedOp "delete"

81− Delete <$> identifier <*> option TruePredicate (reservedOp "where" *> restrictionPredicateP)

81+ Delete <$> relVarNameP <*> option TruePredicate (reservedOp "where" *> restrictionPredicateP)

8282

8383updateP :: Parser DatabaseContextExpr

8484updateP = do

8585 reservedOp "update"

86− relVarName <- identifier

86+ relVarName <- relVarNameP

8787 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaceConsumer)

8888 attributeAssignments <- M.fromList <$> parens (sepBy attributeAssignmentP comma)

8989 return $ Update relVarName attributeAssignments predicate

@@ -166,7 +166,7 @@ addTypeConstructorP = do

166166removeTypeConstructorP :: Parser DatabaseContextExpr

167167removeTypeConstructorP = do

168168 reserved "undata"

169− RemoveTypeConstructor <$> identifier

169+ RemoveTypeConstructor <$> typeConstructorNameP

170170

171171removeAtomFunctionP :: Parser DatabaseContextExpr

172172removeAtomFunctionP = do

@@ -178,10 +178,13 @@ removeDatabaseContextFunctionP = do

178178 reserved "removedatabasecontextfunction"

179179 RemoveDatabaseContextFunction <$> quotedString

180180

181+functionNameP :: Parser AtomFunctionName

182+functionNameP = uncapitalizedIdentifier

183+

181184executeDatabaseContextFunctionP :: Parser DatabaseContextExpr

182185executeDatabaseContextFunctionP = do

183186 reserved "execute"

184− funcName <- identifier

187+ funcName <- functionNameP

185188 args <- parens (sepBy atomExprP comma)

186189 pure (ExecuteDatabaseContextFunction funcName args)

187190

src/bin/TutorialD/Interpreter/Export/Base.hs+1−1

@@ -2,7 +2,7 @@

22module TutorialD.Interpreter.Export.Base where

33import ProjectM36.Base

44import ProjectM36.Error

5−#if __GLASGOW_HASKELL__ <= 802

5+#if __GLASGOW_HASKELL__ < 804

66import Data.Monoid

77#endif

src/bin/TutorialD/Interpreter/Import/Base.hs+1−1

@@ -2,7 +2,7 @@

22module TutorialD.Interpreter.Import.Base where

33import ProjectM36.Base

44import ProjectM36.Error

5−#if __GLASGOW_HASKELL__ <= 802

5+#if __GLASGOW_HASKELL__ < 804

66import Data.Monoid

77#endif

src/bin/TutorialD/Interpreter/RelationalExpr.hs+45−37

@@ -17,12 +17,12 @@ import ProjectM36.MiscUtils

1717

1818--used in projection

1919attributeListP :: RelationalMarkerExpr a => Parser (AttributeNamesBase a)

20−attributeListP =

20+attributeListP =

2121 (reservedOp "all but" >>

22− InvertedAttributeNames . S.fromList <$> sepBy identifier comma) <|>

22+ InvertedAttributeNames . S.fromList <$> sepBy attributeNameP comma) <|>

2323 (reservedOp "all from" >>

2424 RelationalExprAttributeNames <$> relExprP) <|>

25− (AttributeNames . S.fromList <$> sepBy identifier comma)

25+ (AttributeNames . S.fromList <$> sepBy attributeNameP comma)

2626

2727makeRelationP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)

2828makeRelationP = do

@@ -32,12 +32,12 @@ makeRelationP = do

3232 marker <- parseMarkerP

3333 pure $ MakeRelationFromExprs attrExprs (TupleExprs marker tupleExprs)

3434

35−

35+

3636--abstract data type parser- in this context, the type constructor must not include any type arguments

3737--Either Text Int

3838adTypeConstructorP :: Parser TypeConstructor

3939adTypeConstructorP = do

40− tConsName <- capitalizedIdentifier

40+ tConsName <- typeConstructorNameP

4141 tConsArgs <- many typeConstructorP

4242 pure $ ADTypeConstructor tConsName tConsArgs

4343

@@ -47,25 +47,25 @@ tupleExprP = do

4747 attrAssocs <- braces (sepBy tupleAtomExprP comma)

4848 --detect duplicate attribute names

4949 let dupAttrNames = dupes (sort (map fst attrAssocs))

50− if not (null dupAttrNames) then

50+ if not (null dupAttrNames) then

5151 fail ("Attribute names duplicated: " ++ show dupAttrNames)

5252 else

5353 pure (TupleExpr (M.fromList attrAssocs))

5454

5555tupleAtomExprP :: RelationalMarkerExpr a => Parser (AttributeName, AtomExprBase a)

5656tupleAtomExprP = do

57− attributeName <- identifier

57+ attributeName <- attributeNameP

5858 atomExpr <- atomExprP

5959 pure (attributeName, atomExpr)

60−

60+

6161projectP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)

6262projectP = Project <$> braces attributeListP

6363

6464renameClauseP :: Parser (T.Text, T.Text)

6565renameClauseP = do

66− oldAttr <- identifier

66+ oldAttr <- attributeNameP

6767 reservedOp "as"

68− newAttr <- identifier

68+ newAttr <- attributeNameP

6969 pure (oldAttr, newAttr)

7070

7171renameP :: Parser (RelationalExprBase a -> RelationalExprBase a)

@@ -74,7 +74,7 @@ renameP = do

7474 renameList <- braces (sepBy renameClauseP comma)

7575 case renameList of

7676 [] -> pure (Restrict TruePredicate) --no-op when rename list is empty

77− renames ->

77+ renames ->

7878 pure $ \expr -> foldl (\acc (oldAttr, newAttr) -> Rename oldAttr newAttr acc) expr renames

7979

8080whereClauseP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)

@@ -84,7 +84,7 @@ groupClauseP :: RelationalMarkerExpr a => Parser (AttributeNamesBase a, T.Text)

8484groupClauseP = do

8585 attrs <- braces attributeListP

8686 reservedOp "as"

87− newAttrName <- identifier

87+ newAttrName <- attributeNameP

8888 pure (attrs, newAttrName)

8989

9090groupP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)

@@ -97,26 +97,26 @@ groupP = do

9797ungroupP :: Parser (RelationalExprBase a -> RelationalExprBase a)

9898ungroupP = do

9999 reservedOp "ungroup"

100− Ungroup <$> identifier

100+ Ungroup <$> attributeNameP

101101

102102extendP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)

103103extendP = do

104104 reservedOp ":"

105105 Extend <$> braces extendTupleExpressionP

106−

106+

107107semijoinP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a -> RelationalExprBase a)

108108semijoinP = do

109109 reservedOp "semijoin" <|> reservedOp "matching"

110− pure (\exprA exprB ->

110+ pure (\exprA exprB ->

111111 Project (RelationalExprAttributeNames exprA) (Join exprA exprB))

112−

113−antijoinP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a -> RelationalExprBase a)

112+

113+antijoinP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a -> RelationalExprBase a)

114114antijoinP = do

115115 reservedOp "not matching" <|> reservedOp "antijoin"

116116 pure (\exprA exprB ->

117117 Difference exprA (

118118 Project (RelationalExprAttributeNames exprA) (Join exprA exprB)))

119−

119+

120120relOperators :: RelationalMarkerExpr a => [[Operator Parser (RelationalExprBase a)]]

121121relOperators = [

122122 [Postfix projectP],

@@ -136,8 +136,15 @@ relOperators = [

136136relExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)

137137relExprP = try withMacroExprP <|> makeExprParser relTerm relOperators

138138

139+--allow for additional characters

140+attributeNameP :: Parser AttributeName

141+attributeNameP = uncapitalizedIdentifier

142+

143+relVarNameP :: Parser RelVarName

144+relVarNameP = uncapitalizedIdentifier

145+

139146relVarP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)

140−relVarP = RelationVariable <$> identifier <*> parseMarkerP

147+relVarP = RelationVariable <$> relVarNameP <*> parseMarkerP

141148

142149relTerm :: RelationalMarkerExpr a => Parser (RelationalExprBase a)

143150relTerm = parens relExprP

@@ -158,13 +165,13 @@ restrictionPredicateP = makeExprParser predicateTerm predicateOperators

158165 <|> relationalBooleanExprP

159166

160167relationalBooleanExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)

161−relationalBooleanExprP =

168+relationalBooleanExprP =

162169 --we can't actually detect if the type is relational boolean, so we just pass it to the next phase

163170 RelationalExprPredicate <$> (parens relExprP <|> relTerm)

164−

171+

165172restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)

166173restrictionAttributeEqualityP = do

167− attributeName <- identifier

174+ attributeName <- attributeNameP

168175 reservedOp "="

169176 AttributeEqualityPredicate attributeName <$> atomExprP

170177

@@ -181,7 +188,7 @@ extendTupleExpressionP = attributeExtendTupleExpressionP

181188

182189attributeExtendTupleExpressionP :: RelationalMarkerExpr a => Parser (ExtendTupleExprBase a)

183190attributeExtendTupleExpressionP = do

184− newAttr <- identifier

191+ newAttr <- attributeNameP

185192 reservedOp ":="

186193 AttributeExtendTupleExpr newAttr <$> atomExprP

187194

@@ -199,27 +206,27 @@ consumeAtomExprP consume = try functionAtomExprP <|>

199206attributeAtomExprP :: Parser (AtomExprBase a)

200207attributeAtomExprP = do

201208 _ <- string "@"

202− AttributeAtomExpr <$> identifier

209+ AttributeAtomExpr <$> attributeNameP

203210

204211nakedAtomExprP :: Parser (AtomExprBase a)

205212nakedAtomExprP = NakedAtomExpr <$> atomP

206213

207214constructedAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a)

208215constructedAtomExprP consume = do

209− dConsName <- capitalizedIdentifier

216+ dConsName <- dataConstructorNameP

210217 dConsArgs <- if consume then sepBy (consumeAtomExprP False) spaceConsumer else pure []

211218 ConstructedAtomExpr dConsName dConsArgs <$> parseMarkerP

212−

219+

213220-- used only for primitive type parsing ?

214221atomP :: Parser Atom

215−atomP = stringAtomP <|>

216− doubleAtomP <|>

217− integerAtomP <|>

222+atomP = stringAtomP <|>

223+ doubleAtomP <|>

224+ integerAtomP <|>

218225 boolAtomP

219−

226+

220227functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

221−functionAtomExprP =

222− FunctionAtomExpr <$> identifier <*> parens (sepBy atomExprP comma) <*> parseMarkerP

228+functionAtomExprP =

229+ FunctionAtomExpr <$> uncapitalizedIdentifier <*> parens (sepBy atomExprP comma) <*> parseMarkerP

223230

224231relationalAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

225232relationalAtomExprP = RelationAtomExpr <$> relExprP

@@ -227,7 +234,7 @@ relationalAtomExprP = RelationAtomExpr <$> relExprP

227234stringAtomP :: Parser Atom

228235stringAtomP = TextAtom <$> quotedString

229236

230−doubleAtomP :: Parser Atom

237+doubleAtomP :: Parser Atom

231238doubleAtomP = DoubleAtom <$> try float

232239

233240integerAtomP :: Parser Atom

@@ -237,15 +244,15 @@ boolAtomP :: Parser Atom

237244boolAtomP = do

238245 val <- char 't' <|> char 'f'

239246 return $ BoolAtom (val == 't')

240−

247+

241248relationAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

242249relationAtomExprP = RelationAtomExpr <$> makeRelationP

243250

244251withMacroExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)

245252withMacroExprP = do

246253 reservedOp "with"

247− macros <- parens (sepBy1 createMacroP comma)

248− With macros <$> relExprP

254+ views <- parens (sepBy1 createMacroP comma)

255+ With views <$> relExprP

249256

250257createMacroP :: RelationalMarkerExpr a => Parser (WithNameExprBase a, RelationalExprBase a)

251258createMacroP = do

@@ -254,4 +261,5 @@ createMacroP = do

254261 expr <- relExprP

255262 marker <- parseMarkerP

256263 pure (WithNameExpr name marker, expr)

257−

264+

265+

src/bin/TutorialD/Interpreter/SchemaOperator.hs+3−3

@@ -42,7 +42,7 @@ isoRestrictP = do

4242 reserved "isorestrict"

4343 relVarIn <- qrelVarP

4444 relvarsOut <- isoRestrictOutRelVarsP

45− IsoRestrict <$> pure relVarIn <*> restrictionPredicateP <*> pure relvarsOut

45+ IsoRestrict relVarIn <$> restrictionPredicateP <*> pure relvarsOut

4646

4747isoRestrictOutRelVarsP :: Parser (RelVarName, RelVarName)

4848isoRestrictOutRelVarsP = (,) <$> qrelVarP <*> qrelVarP

@@ -55,7 +55,7 @@ isoUnionP = do

5555 reserved "isounion"

5656 relVarsIn <- isoUnionInRelVarsP

5757 relVarsOut <- qrelVarP

58− IsoUnion <$> pure relVarsIn <*> restrictionPredicateP <*> pure relVarsOut

58+ IsoUnion relVarsIn <$> restrictionPredicateP <*> pure relVarsOut

5959

6060isoRenameP :: Parser SchemaIsomorph

6161isoRenameP = do

@@ -74,4 +74,4 @@ isoUnionInRelVarsP = (,) <$> qrelVarP <*> qrelVarP

7474evalSchemaOperator :: SessionId -> Connection -> SchemaOperator -> IO (Either RelationalError ())

7575evalSchemaOperator sessionId conn (ModifySchemaExpr expr) = executeSchemaExpr sessionId conn expr

7676evalSchemaOperator sessionId conn (SetCurrentSchema sname) = setCurrentSchemaName sessionId conn sname

77−

77+

src/bin/TutorialD/Interpreter/Types.hs+10−4

@@ -9,18 +9,24 @@ class RelationalMarkerExpr a where

1010instance RelationalMarkerExpr () where

1111 parseMarkerP = pure ()

12−

12+

13+typeConstructorNameP :: Parser TypeConstructorName

14+typeConstructorNameP = capitalizedIdentifier

15+

16+dataConstructorNameP :: Parser DataConstructorName

17+dataConstructorNameP = capitalizedIdentifier

18+

1319-- | Upper case names are type names while lower case names are polymorphic typeconstructor arguments.

1420-- data *Either a b* = Left a | Right b

1521typeConstructorDefP :: Parser TypeConstructorDef

16−typeConstructorDefP = ADTypeConstructorDef <$> capitalizedIdentifier <*> typeVarNamesP

22+typeConstructorDefP = ADTypeConstructorDef <$> typeConstructorNameP <*> typeVarNamesP

1723

1824typeVarNamesP :: Parser [TypeVarName]

1925typeVarNamesP = many uncapitalizedIdentifier

2026

2127-- data Either a b = *Left a* | *Right b*

2228dataConstructorDefP :: Parser DataConstructorDef

23−dataConstructorDefP = DataConstructorDef <$> capitalizedIdentifier <*> many dataConstructorDefArgP

29+dataConstructorDefP = DataConstructorDef <$> typeConstructorNameP <*> many dataConstructorDefArgP

2430

2531-- data *Either a b* = Left *a* | Right *b*

2632dataConstructorDefArgP :: Parser DataConstructorDefArg

@@ -47,7 +53,7 @@ typeConstructorP = relationTypeConstructorP <|>

4753 monoTypeConstructorP

4854

4955monoTypeConstructorP :: Parser TypeConstructor

50−monoTypeConstructorP = ADTypeConstructor <$> capitalizedIdentifier <*> pure [] <|>

56+monoTypeConstructorP = ADTypeConstructor <$> typeConstructorNameP <*> pure [] <|>

5157 TypeVariable <$> uncapitalizedIdentifier

5258

5359

src/bin/TutorialD/tutd.hs+1−1

@@ -7,7 +7,7 @@ import ProjectM36.Server

77import System.IO

88import Options.Applicative

99import System.Exit

10−#if __GLASGOW_HASKELL__ <= 802

10+#if __GLASGOW_HASKELL__ < 804

1111import Data.Monoid

1212#endif

1313import Data.Maybe

src/bin/benchmark/Handles.hs+9−10

@@ -6,7 +6,7 @@ import Options.Applicative

66import TutorialD.Interpreter

77import TutorialD.Interpreter.Base hiding (Parser, option)

88import qualified Data.Text as T

9−#if __GLASGOW_HASKELL__ <= 802

9+#if __GLASGOW_HASKELL__ < 804

1010import Data.Monoid

1111#endif

1212import Control.Monad

@@ -14,7 +14,7 @@ import Control.Monad

1414data HandlesArgs = HandlesArgs {

1515 openCloseCount :: Int,

1616 transactionCount :: Int,

17− dbdir :: FilePath,

17+ dbdir :: FilePath,

1818 tutdSetup :: String,

1919 tutdIterate :: String

2020 }

@@ -40,13 +40,13 @@ parseTutdIterate = strOption (short 'i' <> long "iterate-tutd" <> value "update

4040main :: IO ()

4141main = do

4242 args <- execParser $ info (helper <*> parseArgs) fullDesc

43− replicateM_ (openCloseCount args) (runOpenClose

43+ replicateM_ (openCloseCount args) (runOpenClose

4444 (T.pack (tutdSetup args))

4545 (T.pack (tutdIterate args))

46− (transactionCount args)

46+ (transactionCount args)

4747 (dbdir args))

48−

49−runOpenClose :: T.Text -> T.Text -> Int -> FilePath -> IO ()

48+

49+runOpenClose :: T.Text -> T.Text -> Int -> FilePath -> IO ()

5050runOpenClose tutdSetup' tutdIterate' tCount dbdir' = do

5151 let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir') emptyNotificationCallback []

5252 eConn <- connectProjectM36 connInfo

@@ -56,7 +56,7 @@ runOpenClose tutdSetup' tutdIterate' tCount dbdir' = do

5656 eSess <- createSessionAtHead conn "master"

5757 case eSess of

5858 Left err -> error (show err)

59− Right session ->

59+ Right session ->

6060 --database setup

6161 case parseTutorialD tutdSetup' of

6262 Left err -> error (show err)

@@ -74,9 +74,9 @@ runOpenClose tutdSetup' tutdIterate' tCount dbdir' = do

7474 replicateM_ tCount (runTransaction tutdIterate' session conn)

7575 close conn

7676 printFdCount

77−

77+

7878runTransaction :: T.Text -> SessionId -> Connection -> IO ()

79−runTransaction tutdIterate' sess conn =

79+runTransaction tutdIterate' sess conn =

8080 --run tutd on every iteration

8181 case parseTutorialD tutdIterate' of

8282 Left err -> error (show err)

@@ -95,4 +95,3 @@ runTransaction tutdIterate' sess conn =

9595 case eErr of

9696 Left err -> error (show err)

9797 Right _ -> printFdCount

98−

src/bin/benchmark/bigrel.hs+8−7

@@ -1,4 +1,4 @@

1−{-# LANGUAGE FlexibleInstances #-}

1+{-# LANGUAGE FlexibleInstances, CPP #-}

22{-# OPTIONS_GHC -fno-warn-orphans #-}

33import ProjectM36.Base

44import ProjectM36.Relation

@@ -9,7 +9,6 @@ import qualified ProjectM36.Attribute as A

99import qualified Data.Text as T

1010--import ProjectM36.Relation.Show.CSV

1111import ProjectM36.Relation.Show.HTML

12−import TutorialD.Interpreter.DatabaseContextExpr (interpretDatabaseContextExpr)

1312import ProjectM36.RelationalExpression

1413import ProjectM36.TransactionGraph

1514--import qualified Data.HashSet as HS

@@ -18,16 +17,16 @@ import ProjectM36.TransactionGraph

1817--import qualified Data.Hashable as Hash

1918import qualified Data.Vector as V

2019import Options.Applicative

21−import qualified Data.Map as M

2220import qualified Data.Text.IO as TIO

2321import System.IO

24−import Control.Monad.State

2522import Control.DeepSeq

2623import Data.Text hiding (map)

27−import Data.Monoid

2824import Data.Time.Clock

29−import Data.UUID

3025import Data.UUID.V4

26+#if __GLASGOW_HASKELL__ < 804

27+import Data.Monoid

28+#endif

29+

3130

3231{-

3332dumpcsv :: Relation -> IO ()

@@ -76,7 +75,9 @@ matrixRun (BigrelArgs attributeCount tupleCount tutd) =

7675 case eNewState of

7776 Right newState -> do

7877 let ctx = dbc_context newState

79− TIO.putStrLn $ relationAsHTML (relationVariables ctx M.! "x")

78+ Right x = optimizeAndEvalRelationalExpr env' (RelationVariable "x" ())

79+ env' = RelationalExprEnv ctx graph Nothing

80+ TIO.putStrLn $ relationAsHTML x

8081 Left err -> hPrint stderr err

8182

8283{-

src/lib/ProjectM36/Atom.hs+1−1

@@ -3,7 +3,7 @@ import ProjectM36.Base

33import ProjectM36.Error

44import ProjectM36.DataTypes.Interval

55import qualified Data.Text as T

6−#if __GLASGOW_HASKELL__ <= 802

6+#if __GLASGOW_HASKELL__ < 804

77import Data.Monoid

88#endif

src/lib/ProjectM36/AtomFunction.hs+6−1

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

12module ProjectM36.AtomFunction where

23import ProjectM36.Base

34import ProjectM36.Error

@@ -72,7 +73,11 @@ createScriptedAtomFunction funcName argsType retType = AddAtomFunction funcName

7273 retType]])

7374

7475loadAtomFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [AtomFunction])

76+#ifdef PM36_HASKELL_SCRIPTING

7577loadAtomFunctions = loadFunction

78+#else

79+loadAtomFunctions _ _ _ = pure (Left LoadSymbolError)

80+#endif

7681

7782atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation

7883atomFunctionsAsRelation funcs = mkRelationFromList attrs tups

@@ -81,4 +86,4 @@ atomFunctionsAsRelation funcs = mkRelationFromList attrs tups

8186 Attribute "arguments" TextAtomType]

8287 atomFuncToTuple aFunc = [TextAtom (atomFuncName aFunc),

8388 TextAtom (atomFuncTypeToText aFunc)]

84− atomFuncTypeToText aFunc = T.intercalate " -> " (map prettyAtomType (atomFuncType aFunc))

89+ atomFuncTypeToText aFunc = T.intercalate " -> " (map prettyAtomType (atomFuncType aFunc))

src/lib/ProjectM36/AtomType.hs+45−16

@@ -139,14 +139,37 @@ resolveAttributeExprTypeVars (AttributeAndTypeNameExpr _ tCons _) aType tConsMap

139139

140140-- check that type vars on the right also appear on the left

141141-- check that the data constructor names are unique

142−validateTypeConstructorDef :: TypeConstructorDef -> [DataConstructorDef] -> [RelationalError]

143−validateTypeConstructorDef tConsDef dConsList = execWriter $ do

142+validateTypeConstructorDef :: TypeConstructorDef -> [DataConstructorDef] -> TypeConstructorMapping -> Either RelationalError ()

143+validateTypeConstructorDef tConsDef dConsList tConsMap = do

144144 let duplicateDConsNames = dupes (L.sort (map DCD.name dConsList))

145− mapM_ tell [map DataConstructorNameInUseError duplicateDConsNames]

145+ unless (null duplicateDConsNames) (Left (someErrors (map DataConstructorNameInUseError duplicateDConsNames)))

146146 let leftSideVars = S.fromList (TCD.typeVars tConsDef)

147147 rightSideVars = S.unions (map DCD.typeVars dConsList)

148148 varsDiff = S.difference leftSideVars rightSideVars

149− mapM_ tell [map DataConstructorUsesUndeclaredTypeVariable (S.toList varsDiff)]

149+ when (S.size varsDiff > 0) (Left (someErrors (map DataConstructorUsesUndeclaredTypeVariable (S.toList varsDiff))))

150+ mapM_ (\dConsDef -> validateDataConstructorDef dConsDef tConsDef tConsMap) dConsList

151+

152+--check that the data constructor names are not in use (recursively)

153+validateDataConstructorDef :: DataConstructorDef -> TypeConstructorDef -> TypeConstructorMapping -> Either RelationalError ()

154+validateDataConstructorDef (DataConstructorDef dConsName dConsDefArgs) tConsDef tConsMap =

155+ case findDataConstructor dConsName tConsMap of

156+ Just _ -> Left (DataConstructorNameInUseError dConsName)

157+ Nothing ->

158+ mapM_ (\arg -> validateDataConstructorDefArg arg tConsDef tConsMap) dConsDefArgs

159+

160+

161+validateDataConstructorDefArg :: DataConstructorDefArg -> TypeConstructorDef -> TypeConstructorMapping -> Either RelationalError ()

162+validateDataConstructorDefArg (DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor _ _)) _ _ = Right ()

163+validateDataConstructorDefArg (DataConstructorDefTypeConstructorArg (TypeVariable _)) _ _ = Right ()

164+validateDataConstructorDefArg (DataConstructorDefTypeConstructorArg tCons) tConsDef tConsMap = case findTypeConstructor (TC.name tCons) tConsMap of

165+ Nothing ->

166+ when (TC.name tCons /= TCD.name tConsDef) (Left (NoSuchTypeConstructorName (TC.name tCons))) --allows for recursively-defined types

167+ Just (ADTypeConstructorDef _ tConsArgs, _) -> do --validate that the argument count matches- type matching can occur later

168+ let existingCount = length tConsArgs

169+ newCount = length (TC.arguments tCons)

170+ when (newCount /= existingCount) (Left (ConstructedAtomArgumentCountMismatchError existingCount newCount))

171+ Just (PrimitiveTypeConstructorDef _ _, _) -> pure ()

172+validateDataConstructorDefArg (DataConstructorDefTypeVarNameArg _) _ _ = Right ()

150173

151174atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructorMapping -> TypeVarMap -> Either RelationalError AtomType

152175atomTypeForTypeConstructor = atomTypeForTypeConstructorValidate False

@@ -209,12 +232,11 @@ resolveAttributes attrA attrB =

209232--given two atom types, try to resolve type variables

210233resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType

211234resolveAtomType (ConstructedAtomType tConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) =

212− ConstructedAtomType tConsName <$> resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

213−resolveAtomType typeFromRelation unresolvedType =

214− if typeFromRelation == unresolvedType then

215− Right typeFromRelation

216− else

217− Left (AtomTypeMismatchError typeFromRelation unresolvedType)

235+ ConstructedAtomType tConsName <$> resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

236+resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then

237+ Right typeFromRelation

238+ else

239+ Left (AtomTypeMismatchError typeFromRelation unresolvedType)

218240

219241{-

220242--walk an `AtomType` and apply the type variables in the map

@@ -241,11 +263,13 @@ resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do

241263 Just unresType -> case unresType of

242264 --do we need to recurse for RelationAtomType?

243265 subType@(ConstructedAtomType _ _) -> do

244− resSubType <- resolveAtomType resType subType

245− pure (resKey, resSubType)

246− typ ->

247− let typ' = if isResolvedType typ then typ else resType in

248− pure (resKey, typ')

266+ resSubType <- resolveAtomType resType subType

267+ pure (resKey, resSubType)

268+ TypeVariableType _ -> pure (resKey, resType)

269+ typ -> if typ == resType then

270+ pure (resKey, resType)

271+ else

272+ Left $ AtomTypeMismatchError typ resType

249273 Nothing ->

250274 pure (resKey, resType) --swipe the missing type var from the expected map

251275 tVarList <- mapM (uncurry resolveTypePair) (M.toList resolvedTypeMap)

@@ -343,7 +367,12 @@ atomTypeVerify x y = if x == y then

343367

344368-- | Determine if two typeVars are logically compatible.

345369typeVarMapsVerify :: TypeVarMap -> TypeVarMap -> Bool

346−typeVarMapsVerify a b = M.keysSet a == M.keysSet b && (length . rights) (map (\((_,v1),(_,v2)) -> atomTypeVerify v1 v2) (zip (M.toAscList a) (M.toAscList b))) == M.size a

370+typeVarMapsVerify a b = M.keysSet a == M.keysSet b && (length . rights) zipped == M.size a

371+ where

372+ zipped = zipWith

373+ (curry (\ ((_, v1), (_, v2)) -> atomTypeVerify v1 v2))

374+ (M.toAscList a)

375+ (M.toAscList b)

347376

348377prettyAtomType :: AtomType -> T.Text

349378prettyAtomType (RelationAtomType attrs) = "relation {" `T.append` T.intercalate "," (map prettyAttribute (V.toList attrs)) `T.append` "}"

src/lib/ProjectM36/Atomable.hs+29−29

@@ -56,7 +56,7 @@ class (Eq a, NFData a, Binary a, Show a) => Atomable a where

5656 -- | Creates DatabaseContextExpr necessary to load the type constructor and data constructor into the database.

5757 toAddTypeExpr :: proxy a -> DatabaseContextExpr

5858 default toAddTypeExpr :: (Generic a, AtomableG (Rep a)) => proxy a -> DatabaseContextExpr

59− toAddTypeExpr _ = toAddTypeExprG (from (undefined :: a)) (toAtomType (Proxy :: Proxy a))

59+ toAddTypeExpr _ = toAddTypeExprG (from (error "insufficient laziness" :: a)) (toAtomType (Proxy :: Proxy a))

6060

6161instance Atomable Integer where

6262 toAtom = IntegerAtom

@@ -148,10 +148,10 @@ instance (Atomable a, Atomable b) => Atomable (Either a b) where

148148--convert to ADT list

149149instance Atomable a => Atomable [a] where

150150 toAtom [] = ConstructedAtom "Empty" (listAtomType (toAtomType (Proxy :: Proxy a))) []

151− toAtom (x:xs) = ConstructedAtom "Cons" (listAtomType (toAtomType (Proxy :: Proxy a))) (map toAtom (x:xs))

151+ toAtom (x:xs) = ConstructedAtom "Cons" (listAtomType (toAtomType (Proxy :: Proxy a))) (toAtom x: [toAtom xs])

152152

153153 fromAtom (ConstructedAtom "Empty" _ _) = []

154− fromAtom (ConstructedAtom "Cons" _ (x:xs)) = fromAtom x:map fromAtom xs

154+ fromAtom (ConstructedAtom "Cons" _ [x,y]) = fromAtom x:fromAtom y

155155 fromAtom _ = error "improper fromAtom [a]"

156156

157157 toAtomType _ = ConstructedAtomType "List" (M.singleton "a" (toAtomType (Proxy :: Proxy a)))

@@ -184,17 +184,17 @@ class AtomableG g where

184184instance (Datatype c, AtomableG a) => AtomableG (M1 D c a) where

185185 toAtomG (M1 v) = toAtomG v

186186 fromAtomG atom args = M1 <$> fromAtomG atom args

187− toAtomsG = undefined

187+ toAtomsG = error "invalid toAtomsG in M1 D"

188188 toAtomTypeG _ = ConstructedAtomType (T.pack typeName) M.empty -- generics don't allow us to get the type constructor variables- alternatives?

189189 where

190190 typeName = datatypeName (undefined :: M1 D c a x)

191− toAddTypeExprG (M1 v) (ConstructedAtomType tcName _) = AddTypeConstructor tcDef dataConstructors

191+ toAddTypeExprG ~(M1 v) (ConstructedAtomType tcName _) = AddTypeConstructor tcDef dataConstructors

192192 where

193193 tcDef = ADTypeConstructorDef tcName []

194194 dataConstructors = getConstructorsG v

195195 toAddTypeExprG _ _ = NoOperation

196− getConstructorsG (M1 v) = getConstructorsG v

197− getConstructorArgsG = undefined

196+ getConstructorsG ~(M1 v) = getConstructorsG v

197+ getConstructorArgsG = error "invalid getConstructorArgsG in M1 D"

198198

199199--constructor metadata

200200instance (Constructor c, AtomableG a) => AtomableG (M1 C c a) where

@@ -209,11 +209,11 @@ instance (Constructor c, AtomableG a) => AtomableG (M1 C c a) where

209209 Nothing

210210 where

211211 dName = T.pack (conName (undefined :: M1 C c a x))

212− fromAtomG _ _ = error "unsupported generic traversal"

213− toAtomsG = undefined

214− toAtomTypeG = undefined

215− toAddTypeExprG = undefined

216− getConstructorsG (M1 v) = [DataConstructorDef (T.pack dName) dArgs]

212+ fromAtomG _ _ = error "invalid fromAtomG in M1 C"

213+ toAtomsG = error "invalid toAtomsG in M1 C"

214+ toAtomTypeG = error "invalid toAtomTypeG in M1 C"

215+ toAddTypeExprG = error "invalid toAddTypeExprG in M1 C"

216+ getConstructorsG ~(M1 v) = [DataConstructorDef (T.pack dName) dArgs]

217217 where

218218 dName = conName (undefined :: M1 C c a x)

219219 dArgs = getConstructorArgsG v

@@ -225,9 +225,9 @@ instance (Selector c, AtomableG a) => AtomableG (M1 S c a) where

225225 fromAtomG atom args = M1 <$> fromAtomG atom args

226226 toAtomsG (M1 v) = toAtomsG v

227227 toAtomTypeG (M1 v) = toAtomTypeG v

228− toAddTypeExprG _ _ = undefined

229− getConstructorsG = undefined

230− getConstructorArgsG (M1 v) = getConstructorArgsG v

228+ toAddTypeExprG = error "invalid toAddTypeExprG in M1 S"

229+ getConstructorsG = error "invalid getConstructorsG in M1 S"

230+ getConstructorArgsG ~(M1 v) = getConstructorArgsG v

231231

232232-- field data metadata

233233instance (Atomable a) => AtomableG (K1 c a) where

@@ -237,9 +237,9 @@ instance (Atomable a) => AtomableG (K1 c a) where

237237 headatom [] = error "no more atoms for constructor!"

238238 toAtomsG (K1 v) = [toAtom v]

239239 toAtomTypeG _ = toAtomType (Proxy :: Proxy a)

240− toAddTypeExprG _ _ = undefined

241− getConstructorsG = undefined

242− getConstructorArgsG (K1 _) = [DataConstructorDefTypeConstructorArg tCons]

240+ toAddTypeExprG = error "invalid toAddTypeExprG in K1"

241+ getConstructorsG = error "invalid getConstructorsG in K1"

242+ getConstructorArgsG ~(K1 _) = [DataConstructorDefTypeConstructorArg tCons]

243243 where

244244 tCons = typeToTypeConstructor $ toAtomType (Proxy :: Proxy a)

245245

@@ -261,12 +261,12 @@ typeToTypeConstructor (ConstructedAtomType tcName tvMap)

261261typeToTypeConstructor (TypeVariableType tvName) = TypeVariable tvName

262262

263263instance AtomableG U1 where

264− toAtomG = undefined

264+ toAtomG = error "invalid toAtomG in U1"

265265 fromAtomG _ _ = pure U1

266266 toAtomsG _ = []

267− toAtomTypeG = undefined

268− toAddTypeExprG = undefined

269− getConstructorsG = undefined

267+ toAtomTypeG = error "invalid toAtomTypeG in U1"

268+ toAddTypeExprG = error "invalid toAddTypeExprG in U1"

269+ getConstructorsG = error "invalid getConstructorsG in U1"

270270 getConstructorArgsG _ = []

271271

272272-- product types

@@ -276,23 +276,23 @@ instance (AtomableG a, AtomableG b) => AtomableG (a :*: b) where

276276 where splitargs1 = take splitpoint args

277277 splitargs2 = drop splitpoint args

278278 splitpoint = length args `div` 2

279− toAtomTypeG = undefined

279+ toAtomTypeG = error "invalid toAtomTypeG in :*:"

280280 toAtomsG (x :*: y) = toAtomsG x ++ toAtomsG y

281− toAddTypeExprG _ _ = undefined

282− getConstructorsG = undefined

283− getConstructorArgsG (x :*: y) = getConstructorArgsG x ++ getConstructorArgsG y

281+ toAddTypeExprG = error "invalid toAddTypeExprG in :*:"

282+ getConstructorsG = error "invalid getConstructorsG in :*:"

283+ getConstructorArgsG ~(x :*: y) = getConstructorArgsG x ++ getConstructorArgsG y

284284

285285-- sum types

286286instance (AtomableG a, AtomableG b) => AtomableG (a :+: b) where

287287 toAtomG (L1 x) = toAtomG x

288288 toAtomG (R1 x) = toAtomG x

289289 fromAtomG atom args = (L1 <$> fromAtomG atom args) <|> (R1 <$> fromAtomG atom args)

290− toAtomTypeG = undefined

290+ toAtomTypeG = error "invalid toAtomTypeG in :+:"

291291 toAtomsG (L1 x) = toAtomsG x

292292 toAtomsG (R1 x) = toAtomsG x

293− toAddTypeExprG _ _ = undefined

293+ toAddTypeExprG = error "invalid toAddTypeExprG in :+:"

294294 getConstructorsG _ = getConstructorsG (undefined :: a x) ++ getConstructorsG (undefined :: b x)

295− getConstructorArgsG = undefined

295+ getConstructorArgsG = error "invalid getConstructorArgsG in :+:"

296296

297297--this represents the unimplemented generics traversals which should never be called

298298{-

src/lib/ProjectM36/Client.hs+8−11

@@ -1,4 +1,4 @@

1−{-# LANGUAGE DeriveAnyClass, DeriveGeneric, ScopedTypeVariables, BangPatterns, PackageImports #-}

1+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, ScopedTypeVariables, BangPatterns, MonoLocalBinds #-}

22{-|

33Module: ProjectM36.Client

@@ -137,7 +137,7 @@ import GHC.Conc.Sync

137137

138138import Network.Transport (Transport(closeTransport))

139139#if MIN_VERSION_network_transport_tcp(0,7,0)

140−import Network.Transport.TCP (createTransport, defaultTCPParameters, TCPAddr(..), TCPAddrInfo(..))

140+import Network.Transport.TCP (createTransport, defaultTCPParameters, defaultTCPAddr)

141141import Network.Transport.TCP.Internal (encodeEndPointAddress)

142142#elif MIN_VERSION_network_transport_tcp(0,6,0)

143143import Network.Transport.TCP (createTransport, defaultTCPParameters)

@@ -166,7 +166,6 @@ import qualified STMContainers.Set as StmSet

166166import qualified ProjectM36.Session as Sess

167167import ProjectM36.Session

168168import ProjectM36.Sessions

169−--import "list-t" ListT

170169import Data.Binary (Binary)

171170import GHC.Generics (Generic)

172171import Control.DeepSeq (force)

@@ -275,14 +274,9 @@ remoteDBLookupName = (++) "db-"

275274createLocalNode :: IO (LocalNode, Transport)

276275createLocalNode = do

277276#if MIN_VERSION_network_transport_tcp(0,7,0)

278− let addrInfo = TCPAddrInfo {

279− tcpBindHost = "127.0.0.1",

280− tcpBindPort = "0",

281− tcpExternalAddress = \sn -> ("127.0.0.1", sn)

282− }

283− eLocalTransport <- createTransport (Addressable addrInfo) defaultTCPParameters

277+ eLocalTransport <- createTransport (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters

284278#elif MIN_VERSION_network_transport_tcp(0,6,0)

285− eLocalTransport <- createTransport "127.0.0.1" "0" ) defaultTCPParameters

279+ eLocalTransport <- createTransport "127.0.0.1" "0" (\sn -> ("127.0.0.1", sn)) defaultTCPParameters

286280#else

287281 eLocalTransport <- createTransport "127.0.0.1" "0" defaultTCPParameters

288282#endif

@@ -1199,7 +1193,10 @@ executeDataFrameExpr sessionId conn@(InProcessConnection _) dfExpr = do

11991193 case verified of

12001194 Left err -> pure (Left err)

12011195 Right attrs -> do

1202− let attrOrders = map (\(attr',order') -> DF.AttributeOrder (attributeName attr') order') (zip attrs orders)

1196+ let attrOrders = zipWith

1197+ (DF.AttributeOrder . attributeName)

1198+ attrs

1199+ orders

12031200 case DF.sortDataFrameBy attrOrders . DF.toDataFrame $ rel of

12041201 Left err -> pure (Left err)

12051202 Right dFrame -> do

src/lib/ProjectM36/DataFrame.hs+2−1

@@ -18,7 +18,7 @@ import Data.Maybe

1818import qualified Data.Text as T

1919import Data.Binary

2020import Control.Arrow

21−#if __GLASGOW_HASKELL__ <= 802

21+#if __GLASGOW_HASKELL__ < 804

2222import Data.Monoid

2323#endif

2424

@@ -163,6 +163,7 @@ tupleAsHTML tuple = "<tr>" <> T.concat (L.map tupleFrag (tupleAssocs tuple)) <>

163163 where

164164 tupleFrag tup = "<td>" <> atomAsHTML (snd tup) <> "</td>"

165165 atomAsHTML (RelationAtom rel) = RelHTML.relationAsHTML rel

166+ atomAsHTML (TextAtom t) = """ <> t <> """

166167 atomAsHTML atom = atomToText atom

167168

168169attributesAsHTML :: Attributes -> [AttributeOrder] -> T.Text

src/lib/ProjectM36/DatabaseContextFunction.hs+5

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

12module ProjectM36.DatabaseContextFunction where

23--implements functions which operate as: [Atom] -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr

34import ProjectM36.Base

@@ -61,7 +62,11 @@ createScriptedDatabaseContextFunction :: DatabaseContextFunctionName -> [TypeCon

6162createScriptedDatabaseContextFunction funcName argsIn retArg = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg])

6263

6364loadDatabaseContextFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [DatabaseContextFunction])

65+#ifdef PM36_HASKELL_SCRIPTING

6466loadDatabaseContextFunctions = loadFunction

67+#else

68+loadDatabaseContextFunctions _ _ _ = pure (Left LoadSymbolError)

69+#endif

6570

6671databaseContextFunctionsAsRelation :: DatabaseContextFunctions -> Either RelationalError Relation

6772databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups

src/lib/ProjectM36/FileLock.hs+1−1

@@ -1,4 +1,4 @@

1−{-# LANGUAGE CPP, NamedFieldPuns #-}

1+{-# LANGUAGE CPP #-}

22--cross-platform file locking utilizing POSIX file locking on Unix/Linux and Windows file locking

33--hackage's System.FileLock doesn't support POSIX advisory locks nor locking file based on file descriptors, hence this needless rewrite

44module ProjectM36.FileLock where

src/lib/ProjectM36/IsomorphicSchema.hs+1−2

@@ -13,10 +13,9 @@ import Data.Binary

1313import qualified Data.Map as M

1414import qualified Data.Set as S

1515import qualified Data.List as L

16−#if __GLASGOW_HASKELL__ <= 802

16+#if __GLASGOW_HASKELL__ < 804

1717import Data.Monoid

1818#endif

19−

2019-- isomorphic schemas offer bi-directional functors between two schemas

2120

2221--TODO: note that renaming a relvar should alter any stored isomorphisms as well

src/lib/ProjectM36/Key.hs+1−1

@@ -2,7 +2,7 @@ module ProjectM36.Key where

22import ProjectM36.Base

33import ProjectM36.Relation

44import qualified Data.Set as S

5−#if __GLASGOW_HASKELL__ <= 802

5+#if __GLASGOW_HASKELL__ < 804

66import Data.Monoid

77#endif

src/lib/ProjectM36/Relation/Show/HTML.hs+3−2

@@ -8,10 +8,10 @@ import qualified Data.List as L

88import Data.Text (Text, pack)

99import qualified Data.Text as T

1010import qualified Data.Text.IO as TIO

11−import qualified Data.Vector as V

12−#if __GLASGOW_HASKELL__ <= 802

11+#if __GLASGOW_HASKELL__ < 804

1312import Data.Monoid

1413#endif

14+import qualified Data.Vector as V

1515

1616attributesAsHTML :: Attributes -> Text

1717attributesAsHTML attrs = "<tr>" <> T.concat (map oneAttrHTML (V.toList attrs)) <> "</tr>"

@@ -53,6 +53,7 @@ tupleAsHTML tuple = "<tr>" <> T.concat (L.map tupleFrag (tupleAssocs tuple)) <>

5353 where

5454 tupleFrag tup = "<td>" <> atomAsHTML (snd tup) <> "</td>"

5555 atomAsHTML (RelationAtom rel) = relationAsHTML rel

56+ atomAsHTML (TextAtom t) = """ <> t <> """

5657 atomAsHTML atom = atomToText atom

5758

5859tupleSetAsHTML :: RelationTupleSet -> Text

src/lib/ProjectM36/Relation/Show/Term.hs+1−1

@@ -9,7 +9,7 @@ import ProjectM36.Attribute hiding (null)

99import qualified Data.List as L

1010import qualified Data.Text as T

1111import Control.Arrow hiding (left)

12−#if __GLASGOW_HASKELL__ <= 802

12+#if __GLASGOW_HASKELL__ < 804

1313import Data.Monoid

1414#endif

1515import ProjectM36.WCWidth --guess the width that the character will appear as in the terminal

src/lib/ProjectM36/RelationalExpression.hs+29−21

@@ -21,27 +21,29 @@ import qualified ProjectM36.Attribute as A

2121import qualified Data.Map as M

2222import qualified Data.HashSet as HS

2323import qualified Data.Set as S

24−import Control.Monad.RWS.Strict as RWS hiding (join)

25−import Control.Monad.Trans.Class (lift)

26−import Control.Exception

24+import Control.Monad.State hiding (join)

2725import Data.Maybe

2826import Data.Either

2927import Data.Char (isUpper)

28+import Data.Time

29+import qualified Data.List.NonEmpty as NE

30+import Data.Functor.Identity

3031import qualified Data.Text as T

3132import qualified Data.Vector as V

3233import qualified ProjectM36.TypeConstructorDef as TCD

34+import qualified Control.Monad.RWS.Strict as RWS

35+import Control.Monad.RWS.Strict (RWST, execRWST, runRWST)

3336import Control.Monad.Except hiding (join)

3437import Control.Monad.Trans.Except (except)

3538import Control.Monad.Reader as R hiding (join)

3639import ProjectM36.NormalizeExpr

3740import ProjectM36.WithNameExpr

3841import Test.QuickCheck

42+#ifdef PM36_HASKELL_SCRIPTING

3943import GHC hiding (getContext)

44+import Control.Exception

4045import GHC.Paths

41−import Data.Time.Clock

42−import Data.Time.Calendar

43−import qualified Data.List.NonEmpty as NE

44−import Data.Functor.Identity

46+#endif

4547

4648data DatabaseContextExprDetails = CountUpdatedTuples

4749

@@ -367,12 +369,16 @@ setRelVar relVarName relExpr = do

367369 --prevent recursive relvar definition

368370 let newRelVars = M.insert relVarName relExpr $ relationVariables currentContext

369371 potentialContext = currentContext { relationVariables = newRelVars }

370− --determine when to check constraints

371− graph <- dbcGraph

372− tid <- dbcTransId

373− case checkConstraints potentialContext tid graph of

374− Left err -> dbErr err

375− Right _ -> putStateContext potentialContext

372+ --optimization: if the relexpr is unchanged, skip the update

373+ if M.lookup relVarName (relationVariables currentContext) == Just relExpr then

374+ pure ()

375+ else do

376+ --determine when to check constraints

377+ graph <- dbcGraph

378+ tid <- dbcTransId

379+ case checkConstraints potentialContext tid graph of

380+ Left err -> dbErr err

381+ Right _ -> putStateContext potentialContext

376382

377383-- it is not an error to delete a relvar which does not exist, just like it is not an error to insert a pre-existing tuple into a relation

378384deleteRelVar :: RelVarName -> DatabaseContextEvalMonad ()

@@ -520,9 +526,9 @@ evalGraphRefDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do

520526 let oldTypes = typeConstructorMapping currentContext

521527 tConsName = TCD.name tConsDef

522528 -- validate that the constructor's types exist

523− case validateTypeConstructorDef tConsDef dConsDefList of

524− errs@(_:_) -> dbErr (someErrors errs)

525− [] | T.null tConsName || not (isUpper (T.head tConsName)) -> dbErr (InvalidAtomTypeName tConsName)

529+ case validateTypeConstructorDef tConsDef dConsDefList oldTypes of

530+ Left err -> throwError err

531+ Right () | T.null tConsName || not (isUpper (T.head tConsName)) -> dbErr (InvalidAtomTypeName tConsName)

526532 | isJust (findTypeConstructor tConsName oldTypes) -> dbErr (AtomTypeNameInUseError tConsName)

527533 | otherwise -> do

528534 let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]

@@ -598,7 +604,6 @@ evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArg

598604 case evalDatabaseContextFunction func (rights eAtomArgs) context of

599605 Left err -> dbErr err

600606 Right newContext -> putStateContext newContext

601−

602607data DatabaseContextIOEvalEnv = DatabaseContextIOEvalEnv

603608 { dbcio_transId :: TransactionId,

604609 dbcio_graph :: TransactionGraph,

@@ -638,6 +643,12 @@ getDBCIORelationalExprEnv = do

638643 pure $ mkRelationalExprEnv context (dbcio_graph env)

639644

640645evalGraphRefDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())

646+#if !defined(PM36_HASKELL_SCRIPTING)

647+evalGraphRefDatabaseContextIOExpr AddAtomFunction{} = pure (Left (ScriptError ScriptCompilationDisabledError))

648+evalGraphRefDatabaseContextIOExpr AddDatabaseContextFunction{} = pure (Left (ScriptError ScriptCompilationDisabledError))

649+evalGraphRefDatabaseContextIOExpr LoadAtomFunctions{} = pure (Left (ScriptError ScriptCompilationDisabledError))

650+evalGraphRefDatabaseContextIOExpr LoadDatabaseContextFunctions{} = pure (Left (ScriptError ScriptCompilationDisabledError))

651+#else

641652evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName funcType script) = do

642653 eScriptSession <- requireScriptSession

643654 currentContext <- getDBCIOContext

@@ -671,7 +682,6 @@ evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName funcType script) = d

671682 Right eContext -> case eContext of

672683 Left err -> pure (Left err)

673684 Right context' -> putDBCIOContext context'

674−

675685evalGraphRefDatabaseContextIOExpr (AddDatabaseContextFunction funcName funcType script) = do

676686 eScriptSession <- requireScriptSession

677687 currentContext <- getDBCIOContext

@@ -713,7 +723,6 @@ evalGraphRefDatabaseContextIOExpr (AddDatabaseContextFunction funcName funcType

713723 Right eContext -> case eContext of

714724 Left err -> pure (Left err)

715725 Right context' -> putDBCIOContext context'

716−

717726evalGraphRefDatabaseContextIOExpr (LoadAtomFunctions modName funcName modPath) = do

718727 currentContext <- getDBCIOContext

719728 eLoadFunc <- liftIO $ loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath

@@ -730,7 +739,6 @@ evalGraphRefDatabaseContextIOExpr (LoadDatabaseContextFunctions modName funcName

730739 Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }

731740 mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)

732741 in putDBCIOContext newContext

733−

734742evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs range) = do

735743 --Define

736744 currentContext <- getDBCIOContext

@@ -761,7 +769,7 @@ evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs

761769 case runDatabaseContextEvalMonad currentContext evalEnv (setRelVar relVarName (ExistingRelation rel)) of

762770 Left err -> pure (Left err)

763771 Right dbstate' -> putDBCIOContext (dbc_context dbstate')

764−

772+#endif

765773{-

766774updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> TransactionGraph -> RelationTuple -> Either RelationalError RelationTuple

767775updateTupleWithAtomExprs exprMap context graph tupIn = do

src/lib/ProjectM36/ScriptSession.hs+59−44

@@ -1,11 +1,12 @@

1−{-# LANGUAGE MagicHash, UnboxedTuples #-}

2−#if MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)

3−{-# LANGUAGE GADTs #-}

1+{-# LANGUAGE UnboxedTuples, KindSignatures, DataKinds #-}

2+#ifdef PM36_HASKELL_SCRIPTING

3+{-# LANGUAGE MagicHash #-}

44#endif

55module ProjectM36.ScriptSession where

7+#ifdef PM36_HASKELL_SCRIPTING

78import ProjectM36.Error

8−

9+import GHC

910import Control.Exception

1011import Control.Monad

1112import System.IO.Error

@@ -16,8 +17,6 @@ import System.FilePath

1617import System.Info (os, arch)

1718import Data.Text (Text, unpack)

1819import Data.Maybe

19−

20−import GHC

2120import GHC.Paths (libdir)

2221#if __GLASGOW_HASKELL__ >= 800

2322import GHC.LanguageExtensions

@@ -36,25 +35,41 @@ import Unsafe.Coerce

3635#if __GLASGOW_HASKELL__ >= 802

3736import Type

3837#elif __GLASGOW_HASKELL__ >= 710

39−import Type hiding (pprTyThing)

38+import Type hiding (pprTyThing)

4039#else

4140#endif

42−

4341import GHC.Exts (addrToAny#)

4442import GHC.Ptr (Ptr(..))

4543import Encoding

44+#endif

45+

4646

4747data ScriptSession = ScriptSession {

48− hscEnv :: HscEnv,

48+#ifdef PM36_HASKELL_SCRIPTING

49+ hscEnv :: HscEnv,

4950 atomFunctionBodyType :: Type,

5051 dbcFunctionBodyType :: Type

52+#endif

5153 }

52−

53−newtype ScriptSessionError = ScriptSessionLoadError GhcException

54+

55+#ifdef PM36_HASKELL_SCRIPTING

56+data ScriptSessionError = ScriptSessionLoadError GhcException

57+ | ScriptingDisabled

5458 deriving (Show)

59+#else

60+data ScriptSessionError = ScriptingDisabled

61+ deriving (Show)

62+#endif

63+

64+data LoadSymbolError = LoadSymbolError

65+type ModName = String

66+type FuncName = String

5567

5668-- | Configure a GHC environment/session which we will use for all script compilation.

5769initScriptSession :: [String] -> IO (Either ScriptSessionError ScriptSession)

70+#if !defined(PM36_HASKELL_SCRIPTING)

71+initScriptSession _ = pure (Left ScriptingDisabled)

72+#else

5873initScriptSession ghcPkgPaths = do

5974 --for the sake of convenience, for developers' builds, include the local cabal sandbox package database and the cabal new-build package database

6075 eHomeDir <- tryJust (guard . isDoesNotExistError) getHomeDirectory

@@ -65,26 +80,26 @@ initScriptSession ghcPkgPaths = do

6580 let ghcVersion = projectVersion dflags

6681

6782 sandboxPkgPaths <- liftIO $ concat <$> mapM glob [

68− "./dist-newstyle/packagedb/ghc-" ++ ghcVersion,

83+ --"./dist-newstyle/packagedb/ghc-" ++ ghcVersion, --rely on cabal 3's ghc.environment install: "cabal install --lib project-m36"

6984 ".cabal-sandbox/*ghc-" ++ ghcVersion ++ "-packages.conf.d",

7085 ".stack-work/install/*/*/" ++ ghcVersion ++ "/pkgdb",

7186 ".stack-work/install/*/pkgdb/", --windows stack build

7287 "C:/sr/snapshots/b201cfe6/pkgdb", --windows stack build- ideally, we could run `stack path --snapshot-pkg-db, but this is sufficient to pass CI

73− homeDir </> ".stack/snapshots/*/*/" ++ ghcVersion ++ "/pkgdb",

74− homeDir </> ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db"

88+ homeDir </> ".stack/snapshots/*/*/" ++ ghcVersion ++ "/pkgdb"

89+ --homeDir </> ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db"

7590 ]

76−

91+

7792 let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths)

78−

79− let dflags' = applyGopts . applyXopts $ dflags { hscTarget = HscInterpreted ,

80− ghcLink = LinkInMemory,

93+

94+ let dflags' = applyGopts . applyXopts $ dflags { hscTarget = HscInterpreted ,

95+ ghcLink = LinkInMemory,

8196 safeHaskell = Sf_Trustworthy,

8297 safeInfer = True,

8398 safeInferred = True,

8499 --verbosity = 3,

85−#if __GLASGOW_HASKELL__ >= 800

100+#if __GLASGOW_HASKELL__ >= 800

86101 trustFlags = map TrustPackage required_packages,

87−#endif

102+#endif

88103 packageFlags = packageFlags dflags ++ packages,

89104#if __GLASGOW_HASKELL__ >= 802

90105 packageDBFlags = map PackageDB localPkgPaths

@@ -97,11 +112,11 @@ initScriptSession ghcPkgPaths = do

97112 applyXopts flags = foldl xopt_set flags xopts

98113#if __GLASGOW_HASKELL__ >= 800

99114 xopts = [OverloadedStrings, ExtendedDefaultRules, ImplicitPrelude, ScopedTypeVariables]

100−#else

115+#else

101116 xopts = [Opt_OverloadedStrings, Opt_ExtendedDefaultRules, Opt_ImplicitPrelude, Opt_ScopedTypeVariables]

102117#endif

103118 gopts = [] --[Opt_DistrustAllPackages, Opt_PackageTrust]

104− required_packages = ["base",

119+ required_packages = ["base",

105120 "containers",

106121 "Glob",

107122 "directory",

@@ -123,13 +138,14 @@ initScriptSession ghcPkgPaths = do

123138 --liftIO $ traceShowM (showSDoc dflags' (ppr packages))

124139 _ <- setSessionDynFlags dflags'

125140 let safeImportDecl mn mQual = ImportDecl {

126−#if __GLASGOW_HASKELL__ >= 802

141+#if __GLASGOW_HASKELL__ >= 802

127142 ideclSourceSrc = NoSourceText,

128143#else

129144 ideclSourceSrc = Nothing,

130145#endif

131−#if MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)

132− ideclExt = noExt,

146+

147+#if __GLASGOW_HASKELL__ >= 806

148+ ideclExt = NoExt,

133149#endif

134150 ideclName = noLoc mn,

135151 ideclPkgQual = Nothing,

@@ -140,6 +156,9 @@ initScriptSession ghcPkgPaths = do

140156 ideclAs = mQual,

141157 ideclHiding = Nothing

142158 }

159+#if __GLASGOW_HASKELL__ >= 806

160+ :: ImportDecl (GhcPass (c :: Pass))

161+#endif

143162 unqualifiedModules = map (\modn -> IIDecl $ safeImportDecl (mkModuleName modn) Nothing) [

144163 "Prelude",

145164 "Data.Map",

@@ -156,7 +175,7 @@ initScriptSession ghcPkgPaths = do

156175 mkModName = noLoc . mkModuleName

157176#else

158177 mkModName = mkModuleName

159−#endif

178+#endif

160179 qualifiedModules = map (\(modn, qualNam) -> IIDecl $ safeImportDecl (mkModuleName modn) (Just (mkModName qualNam))) [

161180 ("Data.Text", "T")

162181 ]

@@ -169,8 +188,8 @@ initScriptSession ghcPkgPaths = do

169188addImport :: String -> Ghc ()

170189addImport moduleNam = do

171190 ctx <- getContext

172− setContext ( (IIDecl $ simpleImportDecl (mkModuleName moduleNam)) : ctx )

173−

191+ setContext (IIDecl (simpleImportDecl (mkModuleName moduleNam)) : ctx)

192+

174193showType :: DynFlags -> Type -> String

175194showType dflags ty = showSDocForUser dflags alwaysQualify (pprTypeForUser ty)

176195

@@ -195,41 +214,36 @@ compileScript funcType script = do

195214 mErr <- typeCheckScript funcType script

196215 case mErr of

197216 Just err -> pure (Left err)

198− Nothing ->

217+ Nothing ->

199218 --catch exception here

200219 --we could potentially wrap the script with Atom pattern matching so that the script doesn't have to do it, but the change to an Atom ADT should make it easier. Still, it would be nice if the script didn't have to handle a list of arguments, for example.

201220 -- we can't use dynCompileExpr here because

202221 Right . unsafeCoerce <$> compileExpr sScript

203−

204−typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError)

222+

223+typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError)

205224typeCheckScript expectedType inp = do

206− dflags <- getSessionDynFlags

225+ dflags <- getSessionDynFlags

207226 --catch exception for SyntaxError

208227#if __GLASGOW_HASKELL__ >= 802

209− funcType <- GHC.exprType TM_Inst (unpack inp)

210−#else

228+ funcType <- GHC.exprType TM_Inst (unpack inp)

229+#else

211230 funcType <- GHC.exprType (unpack inp)

212231#endif

213− --liftIO $ putStrLn $ showType dflags expectedType ++ ":::" ++ showType dflags funcType

232+ --liftIO $ putStrLn $ showType dflags expectedType ++ ":::" ++ showType dflags funcType

214233 if eqType funcType expectedType then

215234 pure Nothing

216235 else

217236 pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType)))

218−

237+

219238mangleSymbol :: Maybe String -> String -> String -> String

220239mangleSymbol pkg module' valsym =

221240 prefixUnderscore ++

222241 maybe "" (\p -> zEncodeString p ++ "_") pkg ++

223242 zEncodeString module' ++ "_" ++ zEncodeString valsym ++ "_closure"

224−

225−type ModName = String

226−type FuncName = String

227−

228−data LoadSymbolError = LoadSymbolError

229243

230244loadFunction :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a)

231245loadFunction modName funcName objPath = do

232−#if __GLASGOW_HASKELL__ >= 802

246+#if __GLASGOW_HASKELL__ >= 802

233247 initObjLinker RetainCAFs

234248#else

235249 initObjLinker

@@ -241,8 +255,8 @@ loadFunction modName funcName objPath = do

241255 Nothing -> pure (Left LoadSymbolError)

242256 Just (Ptr addr) -> case addrToAny# addr of

243257 (# hval #) -> pure (Right hval)

244−

245−prefixUnderscore :: String

258+

259+prefixUnderscore :: String

246260prefixUnderscore =

247261 case (os,arch) of

248262 ("mingw32","x86_64") -> ""

@@ -251,3 +265,4 @@ prefixUnderscore =

251265 ("darwin",_) -> "_"

252266 ("cygwin",_) -> "_"

253267 _ -> ""

268+#endif

src/lib/ProjectM36/Server.hs+4−13

@@ -9,9 +9,9 @@ import ProjectM36.FSType

1010import Control.Monad.IO.Class (liftIO)

1111#if MIN_VERSION_network_transport_tcp(0,7,0)

12−import Network.Transport.TCP (createTransport, defaultTCPParameters, TCPAddr(..), TCPAddrInfo(..))

12+import Network.Transport.TCP (createTransport, defaultTCPParameters, defaultTCPAddr)

1313#else

14−import Network.Transport.TCP (createTransport, defaultTCPParameters)

14+import Network.Transport.TCP (createTransport, defaultTCPParameters)

1515#endif

1616import Network.Transport (EndPointAddress(..), newEndPoint, address)

1717import Control.Distributed.Process.Node (initRemoteTable, runProcess, newLocalNode, initRemoteTable)

@@ -59,11 +59,7 @@ serverDefinition testBool ti = defaultProcess {

5959 --unhandledMessagePolicy = Log

6060 }

6161 where

62− testModeHandlers = if not testBool then

63− []

64− else

65− [handleCall (\conn (TestTimeout sessionId) -> handleTestTimeout ti sessionId conn)]

66−

62+ testModeHandlers = [handleCall (\conn (TestTimeout sessionId) -> handleTestTimeout ti sessionId conn) | testBool]

6763

6864initServer :: InitHandler (Connection, DatabaseName, Maybe (MVar EndPointAddress), EndPointAddress) Connection

6965initServer (conn, dbname, mAddressMVar, saddress) = do

@@ -122,12 +118,7 @@ launchServer daemonConfig mAddressMVar = do

122118 let hostname = bindHost daemonConfig

123119 port = bindPort daemonConfig

124120#if MIN_VERSION_network_transport_tcp(0,7,0)

125− addrInfo = TCPAddrInfo {

126− tcpBindHost = hostname,

127− tcpBindPort = show port,

128− tcpExternalAddress = \sn -> (hostname, sn)

129− }

130− etransport <- createTransport (Addressable addrInfo) defaultTCPParameters

121+ etransport <- createTransport (defaultTCPAddr hostname (show port)) defaultTCPParameters

131122#elif MIN_VERSION_network_transport_tcp(0,6,0)

132123 etransport <- createTransport hostname (show port) (\nam -> (hostname, nam)) defaultTCPParameters

133124#else

src/lib/ProjectM36/Server/EntryPoints.hs+1

@@ -1,3 +1,4 @@

1+{-# LANGUAGE MonoLocalBinds #-}

12module ProjectM36.Server.EntryPoints where

23import ProjectM36.Base hiding (inclusionDependencies)

34import ProjectM36.IsomorphicSchema

src/lib/ProjectM36/Server/ParseArgs.hs+1−1

@@ -3,7 +3,7 @@ import ProjectM36.Base

33import ProjectM36.Client

44import Options.Applicative

55import ProjectM36.Server.Config

6−#if __GLASGOW_HASKELL__ <= 802

6+#if __GLASGOW_HASKELL__ < 804

77import Data.Monoid

88#endif

src/lib/ProjectM36/Sessions.hs+3−3

@@ -14,9 +14,11 @@ import ProjectM36.Session

1414import ProjectM36.Relation

1515import ProjectM36.Error

1616import qualified Data.UUID as U

17−import qualified Control.Foldl as Foldl

1817#if MIN_VERSION_stm_containers(1,0,0)

18+import qualified Control.Foldl as Foldl

1919import qualified DeferredFolds.UnfoldlM as UF

20+#else

21+import "list-t" ListT

2022#endif

2123

2224type Sessions = StmMap.Map SessionId Session

@@ -45,5 +47,3 @@ sessionsAsRelation sessions = do

4547 let atomMatrix = map (\(sessionId, session) -> [uuidAtom sessionId, uuidAtom (parentId session)]) sessionAssocs

4648 pure $ mkRelationFromList (attributesFromList [Attribute "sessionid" TextAtomType,

4749 Attribute "parentCommit" TextAtomType]) atomMatrix

48−

49−

src/lib/ProjectM36/Transaction/Persist.hs+36−16

@@ -1,3 +1,4 @@

1+{-# LANGUAGE TypeApplications #-}

12module ProjectM36.Transaction.Persist where

23import ProjectM36.Base

34import ProjectM36.Error

@@ -8,16 +9,18 @@ import ProjectM36.Persist (writeBSFileSync, DiskSync, renameSync)

89import qualified Data.Map as M

910import qualified Data.HashSet as HS

1011import qualified Data.Binary as B

11−--import qualified Data.ByteString as BS

1212import System.FilePath

1313import System.Directory

1414import qualified Data.Text as T

1515import Control.Monad

1616import ProjectM36.ScriptSession

1717import ProjectM36.AtomFunctions.Basic (precompiledAtomFunctions)

18−import Control.Exception

18+

19+#ifdef PM36_HASKELL_SCRIPTING

1920import GHC

21+import Control.Exception

2022import GHC.Paths

23+#endif

2124

2225getDirectoryNames :: FilePath -> IO [FilePath]

2326getDirectoryNames path =

@@ -117,33 +120,40 @@ readAtomFuncs transDir mScriptSession = do

117120 pure (HS.union precompiledAtomFunctions (HS.fromList funcs))

118121

119122loadAtomFunc :: AtomFunctions -> Maybe ScriptSession -> AtomFunctionName -> [AtomType] -> Maybe AtomFunctionBodyScript -> IO AtomFunction

120−loadAtomFunc precompiledFuncs mScriptSession funcName funcType mFuncScript = case mFuncScript of

123+loadAtomFunc precompiledFuncs _mScriptSession funcName _funcType mFuncScript = case mFuncScript of

121124 --handle pre-compiled case- pull it from the precompiled list

122125 Nothing -> case atomFunctionForName funcName precompiledFuncs of

123126 --WARNING: possible landmine here if we remove a precompiled atom function in the future, then the transaction cannot be restored

124127 Left _ -> error ("expected precompiled atom function: " ++ T.unpack funcName)

125128 Right realFunc -> pure realFunc

126129 --handle a real Haskell scripted function- compile and load

127− Just funcScript ->

128− case mScriptSession of

130+ Just _funcScript ->

131+#ifdef PM36_HASKELL_SCRIPTING

132+ case _mScriptSession of

129133 Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"

130134 Just scriptSession -> do

131135 --risk of GHC exception during compilation here

132136 eCompiledScript <- runGhc (Just libdir) $ do

133137 setSession (hscEnv scriptSession)

134− compileScript (atomFunctionBodyType scriptSession) funcScript

138+ compileScript (atomFunctionBodyType scriptSession) _funcScript

135139 case eCompiledScript of

136140 Left err -> throwIO err

137141 Right compiledScript -> pure AtomFunction { atomFuncName = funcName,

138− atomFuncType = funcType,

139− atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript }

142+ atomFuncType = _funcType,

143+ atomFuncBody = AtomFunctionBody (Just _funcScript) compiledScript }

144+#else

145+ error "Haskell scripting is disabled"

146+#endif

140147

141148--if the script session is enabled, compile the script, otherwise, hard error!

142149

143150readAtomFunc :: FilePath -> AtomFunctionName -> Maybe ScriptSession -> AtomFunctions -> IO AtomFunction

151+#if !defined(PM36_HASKELL_SCRIPTING)

152+readAtomFunc _ _ _ _ = error "Haskell scripting is disabled"

153+#else

144154readAtomFunc transDir funcName mScriptSession precompiledFuncs = do

145155 let atomFuncPath = atomFuncsPath transDir

146− (funcType, mFuncScript) <- B.decodeFile atomFuncPath

156+ (funcType, mFuncScript) <- B.decodeFile @([AtomType],Maybe T.Text) atomFuncPath

147157 case mFuncScript of

148158 --handle pre-compiled case- pull it from the precompiled list

149159 Nothing -> case atomFunctionForName funcName precompiledFuncs of

@@ -151,7 +161,8 @@ readAtomFunc transDir funcName mScriptSession precompiledFuncs = do

151161 Left _ -> error ("expected precompiled atom function: " ++ T.unpack funcName)

152162 Right realFunc -> pure realFunc

153163 --handle a real Haskell scripted function- compile and load

154− Just funcScript ->

164+ Just funcScript ->

165+

155166 case mScriptSession of

156167 Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"

157168 Just scriptSession -> do

@@ -164,6 +175,7 @@ readAtomFunc transDir funcName mScriptSession precompiledFuncs = do

164175 Right compiledScript -> pure AtomFunction { atomFuncName = funcName,

165176 atomFuncType = funcType,

166177 atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript }

178+#endif

167179

168180

169181writeDBCFuncs :: DiskSync -> FilePath -> DatabaseContextFunctions -> IO ()

@@ -182,26 +194,34 @@ readDBCFuncs transDir mScriptSession = do

182194 let funcs = mapM ((\name -> readDBCFunc transDir name mScriptSession precompiledDatabaseContextFunctions) . T.pack) funcNames

183195 HS.union basicDatabaseContextFunctions . HS.fromList <$> funcs

184196

185−readDBCFunc :: FilePath -> DatabaseContextFunctionName -> Maybe ScriptSession -> DatabaseContextFunctions -> IO DatabaseContextFunction

197+readDBCFunc :: FilePath -> DatabaseContextFunctionName -> Maybe ScriptSession -> DatabaseContextFunctions -> IO DatabaseContextFunction

198+#if !defined(PM36_HASKELL_SCRIPTING)

199+readDBCFunc transDir funcName _ precompiledFuncs = do

200+#else

186201readDBCFunc transDir funcName mScriptSession precompiledFuncs = do

202+#endif

187203 let dbcFuncPath = dbcFuncsDir transDir </> T.unpack funcName

188− (funcType, mFuncScript) <- B.decodeFile dbcFuncPath

204+ (_funcType, mFuncScript) <- B.decodeFile @([AtomType], Maybe T.Text) dbcFuncPath

189205 case mFuncScript of

190206 Nothing -> case databaseContextFunctionForName funcName precompiledFuncs of

191207 Left _ -> error ("expected precompiled dbc function: " ++ T.unpack funcName)

192208 Right realFunc -> pure realFunc --return precompiled function

193− Just funcScript ->

209+ Just _funcScript ->

210+#ifdef PM36_HASKELL_SCRIPTING

194211 case mScriptSession of

195212 Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"

196213 Just scriptSession -> do

197214 eCompiledScript <- runGhc (Just libdir) $ do

198215 setSession (hscEnv scriptSession)

199− compileScript (dbcFunctionBodyType scriptSession) funcScript

216+ compileScript (dbcFunctionBodyType scriptSession) _funcScript

200217 case eCompiledScript of

201218 Left err -> throwIO err

202219 Right compiledScript -> pure DatabaseContextFunction { dbcFuncName = funcName,

203− dbcFuncType = funcType,

204− dbcFuncBody = DatabaseContextFunctionBody (Just funcScript) compiledScript}

220+ dbcFuncType = _funcType,

221+ dbcFuncBody = DatabaseContextFunctionBody (Just _funcScript) compiledScript}

222+#else

223+ error "Haskell scripting is disabled"

224+#endif

205225

206226writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO ()

207227writeIncDep sync transDir (incDepName, incDep) =

src/lib/ProjectM36/TransactionGraph.hs+14−10

@@ -1,4 +1,4 @@

1−{-# LANGUAGE DeriveAnyClass, DeriveGeneric, FlexibleContexts #-}

1+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, CPP, FlexibleContexts #-}

22module ProjectM36.TransactionGraph where

33import ProjectM36.Base

44import ProjectM36.Error

@@ -24,6 +24,9 @@ import qualified Data.Text as T

2424import GHC.Generics

2525import Data.Binary

2626import Data.Either (lefts, rights, isRight)

27+#if __GLASGOW_HASKELL__ < 804

28+import Data.Monoid

29+#endif

2730import Control.Arrow

2831import Data.Maybe

2932import Data.UUID.V4

@@ -515,15 +518,16 @@ backtrackGraph :: TransactionGraph -> TransactionId -> TransactionIdHeadBacktrac

515518-- tilde, step back one parent link- if a choice must be made, choose the "first" link arbitrarily

516519backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do

517520 trans <- transactionForId currentTid graph

518− let parentIds' = S.toList (parentIds trans)

519− if length parentIds' < 1 then

520− Left RootTransactionTraversalError

521− else do

522− parentTrans <- transactionForId (head parentIds') graph

523− if steps == 1 then

524− pure (transactionId parentTrans)

525− else

526− backtrackGraph graph (transactionId parentTrans) (TransactionIdHeadParentBacktrack (steps - 1))

521+

522+ let parentIds' = S.toAscList (parentIds trans)

523+ case parentIds' of

524+ [] -> Left RootTransactionTraversalError

525+ firstParentId:_ -> do

526+ parentTrans <- transactionForId firstParentId graph

527+ if steps == 1 then

528+ pure (transactionId parentTrans)

529+ else

530+ backtrackGraph graph (transactionId parentTrans) (TransactionIdHeadParentBacktrack (steps - 1))

527531

528532backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do

529533 trans <- transactionForId currentTid graph

src/lib/ProjectM36/TransactionGraph/Persist.hs+3

@@ -24,6 +24,9 @@ import Control.Exception.Base

2424import qualified Data.ByteString as BS

2525import qualified Data.Text.Encoding as TE

2626import Data.ByteString (ByteString)

27+#if __GLASGOW_HASKELL__ < 804

28+import Data.Monoid

29+#endif

2730import qualified Crypto.Hash.SHA256 as SHA256

2831import Control.Arrow

2932import Data.Time.Clock

src/lib/ProjectM36/Tupleable.hs+4−1

@@ -4,13 +4,16 @@

44{-# LANGUAGE ScopedTypeVariables #-}

55{-# LANGUAGE TypeOperators #-}

66{-# LANGUAGE UndecidableInstances #-}

7+{-# LANGUAGE CPP #-}

89module ProjectM36.Tupleable where

910

1011import Data.Foldable

1112import Data.List (partition)

1213import qualified Data.Map as Map

13−--import Data.Monoid

14+#if __GLASGOW_HASKELL__ < 804

15+import Data.Monoid

16+#endif

1417import Data.Proxy

1518import qualified Data.Text as T

1619import qualified Data.Vector as V

stack.ghc8.4.yaml+7−12

@@ -2,29 +2,25 @@

22# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/

44# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)

5−resolver: lts-12.11

5+resolver: lts-12.26

77# Local packages, usually specified by relative directory name

88packages:

99- '.'

1010# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)

1111extra-deps:

12−- data-accessor-transformers-0.2.1.7

13−- data-interval-1.2.0

14−- extended-reals-0.2.1.0

15−- gnuplot-0.5.5.3

16−- aeson-1.2.1.00

12+- data-interval-1.3.0

13+- extended-reals-0.2.3.0

1714- distributed-process-0.7.4

18−- distributed-process-async-0.2.4.1

19−- distributed-process-client-server-0.2.3

20−- distributed-process-extras-0.3.2

21−#- deferred-folds-0.9.7.1

15+- distributed-process-async-0.2.6

16+- distributed-process-client-server-0.2.5.1

17+- distributed-process-extras-0.3.5

2218- rset-1.0.0

2319- hashable-time-0.2.0.2

2420- network-transport-tcp-0.6.0

2521

2622# Override default flag values for local packages and extra-deps

27−flags:

23+flags:

2824 project-m36:

2925 stack: true

3026

@@ -50,4 +46,3 @@ extra-package-dbs: []

5046# compiler-check: newer-minor

5147

5248allow-newer: true

53−

stack.ghc8.6.yamlnew file+53

@@ -0,0 +1,53 @@

1+# This file was automatically generated by stack init

2+# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/

4+# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)

5+resolver: lts-14.3

7+# Local packages, usually specified by relative directory name

8+packages:

9+- '.'

10+# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)

11+extra-deps:

12+- git: https://github.com/haskell-distributed/distributed-process.git

13+ commit: 660d554f6acd2dba8b605c84e8fa69e45708bc14

14+- extended-reals-0.2.3.0

15+- data-interval-2.0.1

16+- stm-containers-1.1.0.4

17+- distributed-static-0.3.9

18+- stm-hamt-1.2.0.4

19+- distributed-process-async-0.2.6

20+- distributed-process-client-server-0.2.5.1

21+- distributed-process-extras-0.3.5

22+- rset-1.0.0

23+- hashable-time-0.2.0.2

24+- network-transport-tcp-0.6.0

25+- megaparsec-7.0.5

26+

27+# Override default flag values for local packages and extra-deps

28+flags:

29+ project-m36:

30+ stack: true

31+

32+# Extra package databases containing global packages

33+extra-package-dbs: []

34+

35+# Control whether we use the GHC we find on the path

36+# system-ghc: true

37+

38+# Require a specific version of stack, using version ranges

39+# require-stack-version: -any # Default

40+# require-stack-version: >= 1.0.0

41+

42+# Override the architecture used by stack, especially useful on Windows

43+# arch: i386

44+# arch: x86_64

45+

46+# Extra directories used by stack for building

47+# extra-include-dirs: [/path/to/dir]

48+# extra-lib-dirs: [/path/to/dir]

49+

50+# Allow a newer minor version of GHC than the snapshot specifies

51+# compiler-check: newer-minor

52+

53+allow-newer: true

stack.ghc8.8.yamlnew file+54

@@ -0,0 +1,54 @@

1+# This file was automatically generated by stack init

2+# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/

4+# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)

5+resolver: lts-15.11

7+# Local packages, usually specified by relative directory name

8+packages:

9+- '.'

10+# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)

11+extra-deps:

12+- git: https://github.com/agentm/distributed-process.git

13+ commit: 688a5b96d4b7b36d90c3db676230b2c943604288

14+- extended-reals-0.2.3.0

15+- data-interval-2.0.1

16+- stm-containers-1.1.0.4

17+- distributed-static-0.3.9

18+- stm-hamt-1.2.0.4

19+- distributed-process-async-0.2.6

20+- distributed-process-client-server-0.2.5.1

21+- distributed-process-extras-0.3.5

22+- rset-1.0.0

23+- hashable-time-0.2.0.2

24+- network-transport-tcp-0.7.0

25+- megaparsec-7.0.5

26+- network-2.8.0.1

27+

28+# Override default flag values for local packages and extra-deps

29+flags:

30+ project-m36:

31+ stack: true

32+

33+# Extra package databases containing global packages

34+extra-package-dbs: []

35+

36+# Control whether we use the GHC we find on the path

37+# system-ghc: true

38+

39+# Require a specific version of stack, using version ranges

40+# require-stack-version: -any # Default

41+# require-stack-version: >= 1.0.0

42+

43+# Override the architecture used by stack, especially useful on Windows

44+# arch: i386

45+# arch: x86_64

46+

47+# Extra directories used by stack for building

48+# extra-include-dirs: [/path/to/dir]

49+# extra-lib-dirs: [/path/to/dir]

50+

51+# Allow a newer minor version of GHC than the snapshot specifies

52+# compiler-check: newer-minor

53+

54+allow-newer: true

test/Relation/Atomable.hs+23−4

@@ -1,5 +1,5 @@

11--Test Atomable typeclass which allows users to use existing Haskell datatypes to marshal them to and from the database as ConstructedAtoms.

2−{-# LANGUAGE DeriveGeneric, DeriveAnyClass, OverloadedStrings #-}

2+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, OverloadedStrings, TypeApplications #-}

33import Test.HUnit

44import ProjectM36.Client

55import Data.Binary

@@ -48,6 +48,11 @@ data Test7T = Test7C (Either Integer Integer)

4848data Test8T = Test8C Test1T

4949 deriving (Show, Generic, Eq, Binary, NFData, Atomable)

5050

51+data User = User

52+ { userFirstName :: Text

53+ , userLastName :: Text

54+ } deriving (Eq, Ord, Show, Generic, NFData, Binary, Atomable)

55+

5156data Test9_4T = Test9_4C {

5257 f9_41 :: Int,

5358 f9_42 :: Int,

@@ -64,15 +69,13 @@ data Test9_5T = Test9_5C {

6469 }

6570 deriving (Show, Generic, Eq, Binary, NFData, Atomable)

6671

67−

6872main :: IO ()

6973main = do

7074 tcounts <- runTestTT testList

7175 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

7276

7377testList :: Test

74−testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testListInstance, testNonEmptyInstance, testADT6Maybe, testADT7Either, testNonPrimitiveValues, testManyFields]

75−

78+testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testSimpleList, testListInstance, testNonEmptyInstance, testADT6Maybe, testADT7Either, testNonPrimitiveValues, testRecordType, testManyFields]

7679

7780-- test some basic data types like int, day, etc.

7881testBasicMarshaling :: Test

@@ -157,6 +160,12 @@ testListInstance = TestCase $ do

157160 let example = TestListC [3,4,5]

158161 assertEqual "List instance" example (fromAtom (toAtom example))

159162

163+testSimpleList :: Test

164+testSimpleList = TestCase $ do

165+ let example = toAtom @[Integer] [1,2,3]

166+ expected = ConstructedAtom "Cons" (ConstructedAtomType "List" (M.fromList [("a",IntegerAtomType)])) [IntegerAtom 1,ConstructedAtom "Cons" (ConstructedAtomType "List" (M.fromList [("a",IntegerAtomType)])) [IntegerAtom 2,ConstructedAtom "Cons" (ConstructedAtomType "List" (M.fromList [("a",IntegerAtomType)])) [IntegerAtom 3,ConstructedAtom "Empty" (ConstructedAtomType "List" (M.fromList [("a",IntegerAtomType)])) []]]]

167+ assertEqual "simple list" expected example

168+

160169testNonEmptyInstance :: Test

161170testNonEmptyInstance = TestCase $ do

162171 let example = TestNonEmptyC [3,4,5]

@@ -167,6 +176,16 @@ testNonPrimitiveValues = TestCase $ do

167176 let example = Test8C (Test1C 3)

168177 assertEqual "non-primitive values" example (fromAtom (toAtom example))

169178

179+testRecordType :: Test

180+testRecordType = TestCase $ do

181+ let example = User { userFirstName = "Bob"

182+ ,userLastName = "Smith"

183+ }

184+ assertEqual "User record" example (fromAtom (toAtom example))

185+ let expected = AddTypeConstructor (ADTypeConstructorDef "User" []) [DataConstructorDef "User" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Text" TextAtomType),DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Text" TextAtomType)]]

186+

187+ assertEqual "User record to database context expr" expected (toAddTypeExpr (Proxy :: Proxy User))

188+

170189--test both odd and even product types with more than 2 fields

171190testManyFields :: Test

172191testManyFields = TestCase $ do

test/Relation/Basic.hs+1−1

@@ -64,7 +64,7 @@ validateAttrTypesMatchTupleAttrTypes rel@(Relation attrs tupSet) = foldr (\tuple

6464 tupleAtomCheck tuple = V.all (== True) (attrChecks tuple)

6565 attrChecks tuple = V.map (\attr -> case atomForAttributeName (A.attributeName attr) tuple of

6666 Left _ -> False

67− Right atom -> (Right $ atomTypeForAtom atom) ==

67+ Right atom -> Right (atomTypeForAtom atom) ==

6868 A.atomTypeForAttributeName (A.attributeName attr) attrs) (attributes rel)

6969

7070simpleRel :: Relation

test/Relation/Export/CSV.hs+23−18

@@ -1,3 +1,5 @@

1+{-# LANGUAGE CPP #-}

13import ProjectM36.Base

24import ProjectM36.Relation.Show.CSV

35import ProjectM36.Relation.Parse.CSV

@@ -11,7 +13,11 @@ import System.Exit

1113import Test.HUnit

1214import Data.Time.Calendar

1315import Data.Time.Clock

16+

17+#if __GLASGOW_HASKELL__ < 804

1418import Data.Monoid

19+#endif

20+

1521{-

1622import qualified Data.Text.Lazy as TL

1723import qualified Data.Text.Lazy.Encoding as TE

@@ -19,9 +25,9 @@ import ProjectM36.Relation.Show.Term

1925import qualified Data.ByteString.Lazy as BS

2026-}

2127

22−main :: IO ()

23−main = do

24− tcounts <- runTestTT $ TestList [testCSVExport,

28+main :: IO ()

29+main = do

30+ tcounts <- runTestTT $ TestList [testCSVExport,

2531 testADTExport]

2632 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

2733

@@ -31,8 +37,8 @@ assertEither x = do

3137 case res of

3238 Left err -> assertFailure (show err) >> undefined

3339 Right val -> pure val

34−

35−testADTExport :: Test

40+

41+testADTExport :: Test

3642testADTExport = TestCase $ do

3743 let adtCSV = "a\nCons 4 (Cons 5 Empty)\n"

3844 attrs = A.attributesFromList [Attribute "a" (listAtomType IntegerAtomType)]

@@ -40,17 +46,17 @@ testADTExport = TestCase $ do

4046 case csvAsRelation attrs basicTypeConstructorMapping adtCSV of

4147 Left err -> assertFailure ("import failure: " <> show err)

4248 Right rel -> assertEqual "import cons list" expectedRel (Right rel)

43−

49+

4450--round-trip various atom types through CSV export/import

4551testCSVExport :: Test

4652testCSVExport = TestCase $ do

4753 now <- getCurrentTime

48− testInterval <- assertEither $ pure (createInterval

49− (DateTimeAtom now)

54+ testInterval <- assertEither $ pure (createInterval

55+ (DateTimeAtom now)

5056 (DateTimeAtom (addUTCTime 86400 now))

5157 True

5258 False)

53− let attrs = A.attributesFromList [Attribute "textattr" TextAtomType,

59+ let attrs = A.attributesFromList [Attribute "textattr" TextAtomType,

5460 Attribute "integerattr" IntegerAtomType,

5561 Attribute "dayattr" DayAtomType,

5662 Attribute "datetimeattr" DateTimeAtomType,

@@ -61,8 +67,8 @@ testCSVExport = TestCase $ do

6167 ]

6268 sampleByteString = "\1\0\244\34\150"

6369 relOrErr = mkRelationFromList attrs [

64− [TextAtom "text atom with \"quote\"",

65− IntegerAtom 123,

70+ [TextAtom "text atom with \"quote\"",

71+ IntegerAtom 123,

6672 DayAtom (fromGregorian 2017 4 10),

6773 DateTimeAtom now,

6874 ByteStringAtom sampleByteString,

@@ -70,19 +76,19 @@ testCSVExport = TestCase $ do

7076 listCons TextAtomType [TextAtom "text1", TextAtom "text2"],

7177 testInterval

7278 ],

73− [TextAtom "second text atom with 漢字",

74− IntegerAtom 314,

79+ [TextAtom "second text atom with 漢字",

80+ IntegerAtom 314,

7581 DayAtom (fromGregorian 1001 6 28),

7682 DateTimeAtom (addUTCTime 360 now),

77− ByteStringAtom sampleByteString,

83+ ByteStringAtom sampleByteString,

7884 listCons IntegerAtomType [IntegerAtom 10, IntegerAtom 11, IntegerAtom 12],

7985 listCons TextAtomType [TextAtom "text5\"", TextAtom "text6\r\n"],

8086 testInterval

8187 ]]

82−

83− case relOrErr of

88+

89+ case relOrErr of

8490 Left err -> assertFailure $ "export relation creation failure: " ++ show err

85− Right rel ->

91+ Right rel ->

8692 case relationAsCSV rel of

8793 Left err -> assertFailure $ "export failed: " ++ show err

8894 Right csvData ->

@@ -91,4 +97,3 @@ testCSVExport = TestCase $ do

9197 case csvAsRelation attrs basicTypeConstructorMapping csvData of -- import csv data back to relation

9298 Left err -> assertFailure $ "re-import failed: " ++ show err

9399 Right rel' -> assertEqual "relation CSV comparison" rel rel'

94−

test/Relation/Tupleable.hs+1−1

@@ -1,4 +1,4 @@

1−{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts, TypeOperators, DeriveAnyClass #-}

1+{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts, DeriveAnyClass #-}

22import Test.HUnit

33import ProjectM36.Tupleable

44import ProjectM36.Atomable

test/Server/Main.hs+2−1

@@ -94,7 +94,8 @@ launchTestServer ti = do

9494 persistenceStrategy = CrashSafePersistence (tempdir </> "db"),

9595 perRequestTimeout = ti,

9696 testMode = True,

97− bindPort = 0

97+ bindPort = 0,

98+ checkFS = False --not stricly needed for these tests

9899 }

99100

100101 launchServer config (Just addressMVar) >> pure ()

test/Server/WebSocket.hs+2−1

@@ -32,7 +32,8 @@ launchTestServer :: IO (PortNumber, DatabaseName)

3232launchTestServer = do

3333 addressMVar <- newEmptyMVar

3434 let config = defaultServerConfig { databaseName = testDatabaseName,

35− bindPort = 0 }

35+ bindPort = 0,

36+ checkFS = False}

3637 testDatabaseName = "test"

3738 -- start normal server

3839 _ <- forkIO (launchServer config (Just addressMVar) >> pure ())

test/TransactionGraph/Persist.hs+11−4

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

12import Test.HUnit

23import ProjectM36.Base

34import ProjectM36.Persist (DiskSync(NoDiskSync))

@@ -5,8 +6,6 @@ import ProjectM36.TransactionGraph.Persist

56import ProjectM36.TransactionGraph

67import ProjectM36.Transaction

78import ProjectM36.DateExamples

8−import ProjectM36.Client

9−import ProjectM36.Relation

109import System.IO.Temp

1110import System.Exit

1211import Data.Either

@@ -17,6 +16,10 @@ import qualified Data.Map as M

1716import qualified Data.Set as S

1817import Data.Time.Clock

1918import Data.Time.Calendar

19+#ifdef PM36_HASKELL_SCRIPTING

20+import ProjectM36.Client

21+import ProjectM36.Relation

22+#endif

2023

2124main :: IO ()

2225main = do

@@ -75,7 +78,10 @@ testDBSimplePersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \temp

7578

7679--only Haskell-scripted dbc and atom functions can be serialized

7780testFunctionPersistence :: Test

78−testFunctionPersistence = TestCase $

81+#if !defined(PM36_HASKELL_SCRIPTING)

82+testFunctionPersistence = TestCase $ pure ()

83+#else

84+testFunctionPersistence = TestCase $

7985 withSystemTempDirectory "m36testdb" $ \tempdir -> do

8086 let dbdir = tempdir </> "dbdir"

8187 connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []

@@ -96,10 +102,11 @@ testFunctionPersistence = TestCase $

96102 res <- executeRelationalExpr sess2 conn2 (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (M.singleton "a" (FunctionAtomExpr "testdisk" [NakedAtomExpr (IntAtom 3)] ()))]))

97103 let expectedRel = mkRelationFromList (attributesFromList [Attribute "a" IntAtomType]) [[IntAtom 3]]

98104 assertEqual "testdisk dbc function run" expectedRel res

99−

105+

100106assertIOEither :: (Show a) => IO (Either a b) -> IO b

101107assertIOEither x = do

102108 ret <- x

103109 case ret of

104110 Left err -> assertFailure (show err) >> undefined

105111 Right val -> pure val

112+#endif

test/TutorialD/Interpreter.hs+30−4

@@ -75,7 +75,10 @@ main = do

7575 testNonEmptyListType,

7676 testUnresolvedAtomTypes,

7777 testWithClause,

78− testAtomFunctionArgumentMismatch

78+ testAtomFunctionArgumentMismatch,

79+ testInvalidDataConstructor,

80+ testBasicList,

81+ testRelationDeclarationMismatch

7982 ]

8083

8184simpleRelTests :: Test

@@ -491,16 +494,22 @@ testEmptyCommits = TestCase $ do

491494 assertEqual "empty insert empty commit" (Right False) dirty'

492495 Right () <- commit sessionId dbconn

493496

494− --update no tuples

497+ --update no tuples- since we defer the restriction, we can only assume the context is dirty, perhaps the constraint checker could offer an optimization here

495498 Right () <- executeDatabaseContextExpr sessionId dbconn (Update "s" (M.singleton "sname" (NakedAtomExpr (TextAtom "Bob"))) (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))

496499 dirty'' <- disconnectedTransactionIsDirty sessionId dbconn

497− assertEqual "empty update empty commit" (Right False) dirty''

500+ assertEqual "empty update empty commit" (Right True) dirty''

501+ Right () <- commit sessionId dbconn

502+

503+ --assign the same rel expr

504+ Right () <- executeDatabaseContextExpr sessionId dbconn (Assign "true" (ExistingRelation relationTrue))

505+ sameREdirty <- disconnectedTransactionIsDirty sessionId dbconn

506+ assertEqual "same relexpr assigned" (Right False) sameREdirty

498507 Right () <- commit sessionId dbconn

499508

500509 --delete no tuples

501510 Right () <- executeDatabaseContextExpr sessionId dbconn (Delete "s" (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))

502511 dirty''' <- disconnectedTransactionIsDirty sessionId dbconn

503− assertEqual "empty delete empty commit" (Right False) dirty'''

512+ assertEqual "empty delete empty commit" (Right True) dirty'''

504513

505514testIntervalAtom :: Test

506515testIntervalAtom = TestCase $ do

@@ -665,3 +674,20 @@ testAtomFunctionArgumentMismatch = TestCase $ do

665674 --wrong argument count

666675 let err2 = "FunctionArgumentCountMismatchError"

667676 expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "x:=relation{tuple{a 5}} where ^gt(@a,1,3)"

677+

678+testInvalidDataConstructor :: Test

679+testInvalidDataConstructor = TestCase $ do

680+ --test that a referenced TypeConstructor in a DataConstructor definition matches the expected count of arguments

681+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

682+ let err1 = "ConstructedAtomArgumentCountMismatchError"

683+ expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "data TestT = TestT Maybe Int"

684+

685+testBasicList :: Test

686+testBasicList = TestCase $ do

687+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

688+ executeTutorialD sessionId dbconn "x := relation{tuple{ a (Cons 1 (Cons 2 Empty)) }}"

689+

690+testRelationDeclarationMismatch :: Test

691+testRelationDeclarationMismatch = TestCase $ do

692+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

693+ expectTutorialDErr sessionId dbconn (T.isPrefixOf "AtomTypeMismatchError") "data A a = A a | B | C; a := relation{a A Integer}{tuple{a A \"1\"}}"

test/TutorialD/Interpreter/AtomFunctionScript.hs+17−9

@@ -1,25 +1,32 @@

1−import TutorialD.Interpreter.TestBase

1+{-# LANGUAGE CPP #-}

22import System.Exit

33import Test.HUnit

4+#ifdef PM36_HASKELL_SCRIPTING

5+import TutorialD.Interpreter.TestBase

46import ProjectM36.Client

57import ProjectM36.Relation

68import ProjectM36.DataTypes.Maybe

79import qualified Data.Vector as V

810import qualified Data.Map as M

11+#endif

912

1013{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

1114main :: IO ()

1215main = do

13− tcounts <- runTestTT (TestList [testBasicAtomFunction,

14− testExceptionAtomFunction,

15− testErrorAtomFunction,

16− testNoArgumentAtomFunction,

17− testArgumentTypeMismatch,

18− testPolymorphicReturnType,

19− testScriptedTypeVariable

20− ])

16+ tcounts <- runTestTT (TestList [

17+#ifdef PM36_HASKELL_SCRIPTING

18+ testBasicAtomFunction,

19+ testExceptionAtomFunction,

20+ testErrorAtomFunction,

21+ testNoArgumentAtomFunction,

22+ testArgumentTypeMismatch,

23+ testPolymorphicReturnType,

24+ testScriptedTypeVariable

25+#endif

26+ ])

2127 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

2228

29+#ifdef PM36_HASKELL_SCRIPTING

2330--add an atom function and run it

2431testBasicAtomFunction :: Test

2532testBasicAtomFunction = TestCase $ do

@@ -112,3 +119,4 @@ testScriptedTypeVariable = TestCase $ do

112119

113120 assertEqual "id function equality" expectedResult result

114121

122+#endif

test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs+13−6

@@ -1,19 +1,26 @@

1−import TutorialD.Interpreter.TestBase

1+{-# LANGUAGE CPP #-}

22import System.Exit

33import Test.HUnit

4+#ifdef PM36_HASKELL_SCRIPTING

5+import TutorialD.Interpreter.TestBase

46import ProjectM36.Client

57import ProjectM36.Relation

68import qualified Data.Text as T

9+#endif

710

811main :: IO ()

912main = do

10− tcounts <- runTestTT (TestList [testBasicDBCFunction,

11− testErrorDBCFunction,

12− testExceptionDBCFunction,

13− testDBCFunctionWithAtomArguments

13+ tcounts <- runTestTT (TestList [

14+#ifdef PM36_HASKELL_SCRIPTING

15+ testBasicDBCFunction,

16+ testErrorDBCFunction,

17+ testExceptionDBCFunction,

18+ testDBCFunctionWithAtomArguments

19+#endif

1420 ])

1521 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

1622

23+#ifdef PM36_HASKELL_SCRIPTING

1724testBasicDBCFunction :: Test

1825testBasicDBCFunction = TestCase $ do

1926 (sess, conn) <- dateExamplesConnection emptyNotificationCallback

@@ -55,4 +62,4 @@ testDBCFunctionWithAtomArguments = TestCase $ do

5562 assertEqual "person relation" expectedPerson result

5663 expectTutorialDErr sess conn (T.isPrefixOf "AtomTypeMismatchError") "execute multiArgFunc(\"fail\", \"fail\")"

5764

58−

65+#endif