bb13048 · project-m36 · git.iko.soy

.appveyor.yml+2−2

compare with master

unifiedsplit

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

18 STACK_ROOT: "c:\\sr"

19 matrix:

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

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

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

22

23platform:

24 - x64

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

37

38#artifacts:

39# - path: project-m36.7z

40−# name: project-m36.7z

40+# name: project-m36.7z

.travis.yml+11−11

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

16matrix:

17 fast_finish: true

18 include:

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

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

20− compiler: ": #stack 8.2.2"

20+ compiler: ": #stack 8.4.4"

21

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

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

23− os: osx

24− os_image: xcode7.3

25− compiler: ": #stack 8.2.2"

23+ compiler: ": #stack 8.6.5"

26

24

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

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.4.3"

28+ compiler: ": #stack 8.6.5"

29

30before_script:

31 - unset CC

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

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

44 - |

45 #Run HLint

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

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

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

48 fi

49 - |

50 #Run Haddock

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

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

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

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

53 fi

54

55after_success:

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

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

10}

11

12fetch_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;

14}

15

16fetch_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';

18}

19

20# 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)

2+

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

8+

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

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

2

10

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

11* 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.

48

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

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

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

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

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

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

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

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

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

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

85

86

86## Development

87## Development

87

88

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.

89

90

90## Related Projects

91## Related Projects

91

92

cabal.project+3−3

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

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

2packages: 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

4

5--necessary for GHC 8.6 support :/

6source-repository-package

7 type: git

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

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

9− tag: 660d554f6acd2dba8b605c84e8fa69e45708bc14

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

5## Prerequisites

6

7* any Linux

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

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

9* cabal (package downloader) installed

10

11## Download and Install

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

19

20## Some Basic TutorialD

21

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.

23

24Note 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.

25

docs/commits_in_constant_time.markdownnew file+134

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

1+# Transactional Database Commits in O(1)

2+

3+A.M.

4+

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

6+

7+## Synopsis

8+

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:

32

33To build with stack:

34

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

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

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

37* Linux, macOS, or Microsoft Windows

38

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

40

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

42* ```cd project-m36```

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

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

44

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

46

47−Alternative building with GHC 8.0.2 or greater:

47+Alternative building with GHC 8.4.4 or greater:

48

49* ```cabal new-build```

50

docs/server_mode.markdown+1−1

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

8

9To 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.

10

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```.

12

13## Connecting an Interactive Client

14

docs/tutd_cheatsheet.markdownnew file+97

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

1+# Tutorial D Cheatsheet

2+

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

4+

5+## Relational Expressions

6+

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

8+

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

16

17## Client Connection

18

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.

20

21## Sample Application

22

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

17import Data.Time.Calendar

18import Control.DeepSeq

19import Data.Proxy

20−#if __GLASGOW_HASKELL__ <= 802

20+#if __GLASGOW_HASKELL__ < 804

21import Data.Monoid

22#endif

23import Data.List

project-m36.cabal+34−10

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

28 Manual: True

29 Default: False

30

31+Flag haskell-scripting

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

33+ Manual: True

34+ Default: True

35+

31Library

36Library

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

33 if impl(ghc>= 8.6)

44 if impl(ghc>= 8.6)

34 Build-Depends: deferred-folds

45 Build-Depends: deferred-folds

35 Exposed-Modules: ProjectM36.Error,

46 Exposed-Modules: ProjectM36.Error,

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

118 GHC-Options: -rdynamic

129 GHC-Options: -rdynamic

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

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

120 Build-Depends: unix

131 Build-Depends: unix

121− CC-Options: -fPIC

132+ CC-Options: -fPIC

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

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

123 Default-Language: Haskell2010

134 Default-Language: Haskell2010

124 Default-Extensions: OverloadedStrings, CPP

135 Default-Extensions: OverloadedStrings, CPP

125− if impl(ghc>= 8)

126− build-depends:

127− ghc-boot, ghci

128 if !flag(stack)

136 if !flag(stack)

129 Build-Depends: deferred-folds

137 Build-Depends: deferred-folds

130

138

131Executable tutd

139Executable tutd

140+ if flag(haskell-scripting)

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

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

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

133− ghc >= 7.8 && < 8.7,

134 ghc-paths,

143 ghc-paths,

135 project-m36,

144 project-m36,

136 containers,

145 containers,

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

158 directory,

167 directory,

159 filepath,

168 filepath,

160 temporary,

169 temporary,

161− megaparsec >= 5.2.0 && < 8,

170+ megaparsec >= 5.2.0 && < 9,

162 haskeline,

171 haskeline,

163 random, MonadRandom,

172 random, MonadRandom,

164 base64-bytestring,

173 base64-bytestring,

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

193 Default-Extensions: OverloadedStrings

202 Default-Extensions: OverloadedStrings

194

203

195Executable project-m36-server

204Executable project-m36-server

205+ if flag(haskell-scripting)

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

196 Build-Depends: base,

207 Build-Depends: base,

197− ghc >= 7.8 && < 8.7,

198 ghc-paths,

208 ghc-paths,

199 project-m36,

209 project-m36,

200 binary,

210 binary,

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

224 list-t,

234 list-t,

225 base64-bytestring

235 base64-bytestring

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

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

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

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

228 if flag(profiler)

238 if flag(profiler)

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

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

230 Default-Language: Haskell2010

240 Default-Language: Haskell2010

231 Default-Extensions: OverloadedStrings

241 Default-Extensions: OverloadedStrings

232

242

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+

233Benchmark basic-benchmark

257Benchmark basic-benchmark

234 Default-Language: Haskell2010

258 Default-Language: Haskell2010

235 Default-Extensions: OverloadedStrings

259 Default-Extensions: OverloadedStrings

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

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

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

498 if flag(profiler)

522 if flag(profiler)

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

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

500−

524+

501Test-Suite test-dataframe

525Test-Suite test-dataframe

502 Default-Language: Haskell2010

526 Default-Language: Haskell2010

503 Main-Is: test/DataFrame.hs

527 Main-Is: test/DataFrame.hs

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

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

28#endif

29

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

31−websocketProxyServer port host pending = do

31+websocketProxyServer port host pending = do

32 conn <- WS.acceptRequest pending

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

34 --phase 1- accept database name for connection

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

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

38 else do

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

40− bracket (createConnection conn dbname port host)

40+ bracket (createConnection conn dbname port host)

41 (\case

42 Right dbconn -> close dbconn

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

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

44 Left err -> sendError conn err

45 Right dbconn -> do

46 eSessionId <- createSessionAtHead dbconn "master"

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

51 _ <- forever $ do

52 pInfo <- promptInfo sessionId dbconn

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

54− sendPromptInfo pInfo conn

54+ sendPromptInfo pInfo conn

55 sendPromptInfo pInfo conn

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

57 case parseOnly parseExecuteMessage msg of

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

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

68#endif

69 Right parsed -> do

70− let timeoutFilter exc = if exc == RequestTimeoutException

70+ let timeoutFilter exc = if exc == RequestTimeoutException

71− then Just exc

71+ then Just exc

72 else Nothing

73 responseHandler = do

74 result <- evalTutorialD sessionId dbconn SafeEvaluation parsed

75 pInfo' <- promptInfo sessionId dbconn

76− sendPromptInfo pInfo' conn

76+ sendPromptInfo pInfo' conn

77 handleOpResult conn dbconn presentation result

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

79 pure ()

80−

80+

81−notificationCallback :: WS.Connection -> NotificationCallback

81+notificationCallback :: WS.Connection -> NotificationCallback

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

83 "evaldnotification" .= evaldNotif

84 ]))

85−

85+

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

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

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

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

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

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

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

114−

114+

115-- get current schema and head name for client

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

117promptInfo sessionId conn = do

118− eHeadName <- headName sessionId conn

118+ eHeadName <- headName sessionId conn

119 eSchemaName <- currentSchemaName sessionId conn

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

121−

121+

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

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

124

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

126data Presentation = Presentation {

127− jsonPresentation :: Bool,

127+ jsonPresentation :: Bool,

128 textPresentation :: Bool,

129 htmlPresentation :: Bool }

130−

130+

131data PresentationFlag = JSONFlag | TextFlag | HTMLFlag

132−

132+

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

134parseExecuteMessage = do

135 _ <- string "executetutd/"

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

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

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

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

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

140 JSONFlag -> acc {jsonPresentation = True}

141 TextFlag -> acc {textPresentation = True}

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

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

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

28import System.Directory (getHomeDirectory)

29import qualified Data.Text as T

30import System.IO (hPutStrLn, stderr)

31−#if __GLASGOW_HASKELL__ <= 802

31+#if __GLASGOW_HASKELL__ < 804

32import Data.Monoid

33#endif

34import Data.List (isPrefixOf)

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

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

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

63 fmap DatabaseContextIOExprOp (dbContextIOExprP <* eof)

64−

64+

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

66safeInterpreterParserP :: Parser ParsedOperation

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

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

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

79 where

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

81−

81+

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

83parseTutorialD = parse interpreterParserP ""

84

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

106 else

107 pure res

108 _ -> pure res

109−

109+

110− (DatabaseContextExprOp execOp) ->

110+ (DatabaseContextExprOp execOp) ->

111− eHandler $ C.executeDatabaseContextExpr sessionId conn execOp

111+ eHandler $ C.executeDatabaseContextExpr sessionId conn execOp

112−

112+

113− (DatabaseContextIOExprOp execOp) ->

113+ (DatabaseContextIOExprOp execOp) ->

114 if needsSafe then

115 unsafeError

116 else

117 eHandler $ C.executeDatabaseContextIOExpr sessionId conn execOp

118−

118+

119 (GraphOp execOp) -> do

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

121 eIsDirty <- C.disconnectedTransactionIsDirty sessionId conn

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

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

123 settings = Settings {complete = noCompletion,

124 historyFile = Nothing,

125 autoAddHistory = False}

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

143 pure (DisplayErrorResult "Graph operation cancelled.")

144 else

145 runGraphOp

146−

146+

147 (ConvenienceGraphOp execOp) ->

148 eHandler $ evalConvenienceGraphOp sessionId conn execOp

149

150 (ROGraphOp execOp) -> do

151 opResult <- evalROGraphOp sessionId conn execOp

152− case opResult of

152+ case opResult of

153 Left err -> barf err

154 Right rel -> pure (DisplayRelationResult rel)

155−

155+

156 (SchemaOp execOp) ->

157 eHandler $ evalSchemaOperator sessionId conn execOp

158−

158+

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

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

160 if needsSafe then

161 unsafeError

162 else do

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

174 case exprErr of

175 Left err -> barf err

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

177−

177+

178− (ImportDBContextOp execOp) ->

178+ (ImportDBContextOp execOp) ->

179 if needsSafe then

180 unsafeError

181 else do

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

183 case eErr of

184 Left err -> barf err

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

186−

186+

187− (InfoOp execOp) ->

187+ (InfoOp execOp) ->

188 if needsSafe then

189 unsafeError

190 else

191 case evalInformationOperator execOp of

192 Left err -> pure (DisplayErrorResult err)

193 Right info -> pure (DisplayResult info)

194−

194+

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

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

197 if needsSafe then

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

221 case eErr of

222 Left err -> barf err

223 Right () -> return QuietSuccessResult

224−

224+

225−type GhcPkgPath = String

225+type GhcPkgPath = String

226type TutorialDExec = String

227type CheckFS = Bool

228−

228+

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

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

231

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

256 Just line -> do

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

258 reprLoop config sessionId conn

259−

259+

260

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

262−runTutorialD sessionId conn mPromptLength tutd =

262+runTutorialD sessionId conn mPromptLength tutd =

263 case parseTutorialD tutd of

264− Left err ->

264+ Left err ->

265 displayOpResult $ DisplayParseErrorResult mPromptLength err

266 Right parsed ->

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

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

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

1{-# LANGUAGE DeriveGeneric, CPP #-}

2module TutorialD.Interpreter.Base (

3− module TutorialD.Interpreter.Base,

3+ module TutorialD.Interpreter.Base,

4 module Text.Megaparsec,

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

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

6 module Text.Megaparsec.Char,

7 module Control.Applicative

8#else

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

35import System.IO

36import ProjectM36.Relation.Show.Term

37import GHC.Generics

38−#if __GLASGOW_HASKELL__ <= 802

38+#if __GLASGOW_HASKELL__ < 804

39import Data.Monoid

40#endif

41import qualified Data.UUID as U

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

54displayOpResult QuitResult = return ()

55displayOpResult (DisplayResult out) = TIO.putStrLn out

56displayOpResult (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

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

59displayOpResult QuietSuccessResult = return ()

60displayOpResult (DisplayRelationResult rel) = do

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

83

84spaceConsumer :: Parser ()

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

86−

86+

87opChar :: Parser Char

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

89

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

102identifier :: Parser Text

103identifier = do

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

105+ identifierRemainder istart

106+

107+identifierRemainder :: Char -> Parser Text

108+identifierRemainder c = do

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

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

106 spaceConsumer

110 spaceConsumer

107− pure (pack (istart:irest))

111+ pure (pack (c:rest))

108

112

109symbol :: ParseStr -> Parser Text

113symbol :: ParseStr -> Parser Text

110#if MIN_VERSION_megaparsec(6,0,0)

114#if MIN_VERSION_megaparsec(6,0,0)

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

149float = Lex.float

153float = Lex.float

150

154

151capitalizedIdentifier :: Parser Text

155capitalizedIdentifier :: Parser Text

152−capitalizedIdentifier = do

156+capitalizedIdentifier =

153− fletter <- upperChar

157+ upperChar >>= identifierRemainder

154− restOfIdentifier_ fletter

158+

155−

156−restOfIdentifier_ :: Char -> Parser Text

157−restOfIdentifier_ fletter = do

158− rest <- option "" identifier

159− spaceConsumer

160− pure (T.cons fletter rest)

161−

162uncapitalizedIdentifier :: Parser Text

159uncapitalizedIdentifier :: Parser Text

163−uncapitalizedIdentifier = do

160+uncapitalizedIdentifier =

164− fletter <- lowerChar

161+ lowerChar >>= identifierRemainder

165− restOfIdentifier_ fletter

166

162

167showRelationAttributes :: Attributes -> Text

163showRelationAttributes :: Attributes -> Text

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

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

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

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

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

171 attrsL = V.toList attrs

167 attrsL = V.toList attrs

172

168

173−type PromptLength = Int

169+type PromptLength = Int

174

170

175#if MIN_VERSION_megaparsec(7,0,0)

171#if MIN_VERSION_megaparsec(7,0,0)

176−type ParserError = ParseErrorBundle Text Void

172+type ParserError = ParseErrorBundle T.Text Void

177#elif MIN_VERSION_megaparsec(6,0,0)

173#elif MIN_VERSION_megaparsec(6,0,0)

178type ParserError = ParseError Char Void

174type ParserError = ParseError Char Void

179−#else

175+#else

180−type ParserError = ParseError Char Dec

176+type ParserError = ParseError Char Dec

181#endif

177#endif

182

178

183data TutorialDOperatorResult = QuitResult |

179data TutorialDOperatorResult = QuitResult |

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

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

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

190 QuietSuccessResult

186 QuietSuccessResult

191 deriving (Generic)

187 deriving (Generic)

192−

188+

193type TransactionGraphWasUpdated = Bool

189type TransactionGraphWasUpdated = Bool

194

190

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

191--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

197tripleQuotedString = do

193tripleQuotedString = do

198 _ <- tripleQuote

194 _ <- tripleQuote

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

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

200−

196+

201normalQuotedString :: Parser Text

197normalQuotedString :: Parser Text

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

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

203

199

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

206

202

207uuidP :: Parser U.UUID

203uuidP :: Parser U.UUID

208uuidP = do

204uuidP = do

209− uuidStart <- count 8 hexDigitChar

205+ uuidStart <- count 8 hexDigitChar

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

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

211 uuidMid1 <- count 4 hexDigitChar

207 uuidMid1 <- count 4 hexDigitChar

212 _ <- char '-'

208 _ <- char '-'

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

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

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

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

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

228 Just stamp' -> pure stamp'

224 Just stamp' -> pure stamp'

229−

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

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

12import qualified ProjectM36.RelationalExpression as RE

13import ProjectM36.Key

14import ProjectM36.FunctionalDependency

15−#if __GLASGOW_HASKELL__ <= 802

15+#if __GLASGOW_HASKELL__ < 804

16import Data.Monoid

17#endif

18import Data.Functor

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

44assignP :: Parser DatabaseContextExpr

45assignP = do

46 relVarName <- try $ do

47− relVarName <- identifier

47+ relVarName <- relVarNameP

48 reservedOp ":="

49 return relVarName

50 Assign relVarName <$> relExprP

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

59insertP :: Parser DatabaseContextExpr

60insertP = do

61 reservedOp "insert"

62− relvar <- identifier

62+ relvar <- relVarNameP

63 Insert relvar <$> relExprP

64

65defineP :: Parser DatabaseContextExpr

66defineP = do

67 relVarName <- try $ do

68− relVarName <- identifier

68+ relVarName <- relVarNameP

69 reservedOp "::"

70 return relVarName

71 Define relVarName <$> makeAttributeExprsP

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

73undefineP :: Parser DatabaseContextExpr

74undefineP = do

75 reservedOp "undefine"

76− Undefine <$> identifier

76+ Undefine <$> relVarNameP

77

78deleteP :: Parser DatabaseContextExpr

79deleteP = do

80 reservedOp "delete"

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

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

82

83updateP :: Parser DatabaseContextExpr

84updateP = do

85 reservedOp "update"

86− relVarName <- identifier

86+ relVarName <- relVarNameP

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

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

89 return $ Update relVarName attributeAssignments predicate

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

166removeTypeConstructorP :: Parser DatabaseContextExpr

167removeTypeConstructorP = do

168 reserved "undata"

169− RemoveTypeConstructor <$> identifier

169+ RemoveTypeConstructor <$> typeConstructorNameP

170

171removeAtomFunctionP :: Parser DatabaseContextExpr

172removeAtomFunctionP = do

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

178 reserved "removedatabasecontextfunction"

179 RemoveDatabaseContextFunction <$> quotedString

180

181+functionNameP :: Parser AtomFunctionName

182+functionNameP = uncapitalizedIdentifier

183+

181executeDatabaseContextFunctionP :: Parser DatabaseContextExpr

184executeDatabaseContextFunctionP :: Parser DatabaseContextExpr

182executeDatabaseContextFunctionP = do

185executeDatabaseContextFunctionP = do

183 reserved "execute"

186 reserved "execute"

184− funcName <- identifier

187+ funcName <- functionNameP

185 args <- parens (sepBy atomExprP comma)

188 args <- parens (sepBy atomExprP comma)

186 pure (ExecuteDatabaseContextFunction funcName args)

189 pure (ExecuteDatabaseContextFunction funcName args)

187

190

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

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

2module TutorialD.Interpreter.Export.Base where

3import ProjectM36.Base

4import ProjectM36.Error

5−#if __GLASGOW_HASKELL__ <= 802

5+#if __GLASGOW_HASKELL__ < 804

6import Data.Monoid

7#endif

8

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

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

2module TutorialD.Interpreter.Import.Base where

3import ProjectM36.Base

4import ProjectM36.Error

5−#if __GLASGOW_HASKELL__ <= 802

5+#if __GLASGOW_HASKELL__ < 804

6import Data.Monoid

7#endif

8

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

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

17

18--used in projection

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

20−attributeListP =

20+attributeListP =

21 (reservedOp "all but" >>

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

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

23 (reservedOp "all from" >>

24 RelationalExprAttributeNames <$> relExprP) <|>

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

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

26

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

28makeRelationP = do

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

32 marker <- parseMarkerP

33 pure $ MakeRelationFromExprs attrExprs (TupleExprs marker tupleExprs)

34

35−

35+

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

37--Either Text Int

38adTypeConstructorP :: Parser TypeConstructor

39adTypeConstructorP = do

40− tConsName <- capitalizedIdentifier

40+ tConsName <- typeConstructorNameP

41 tConsArgs <- many typeConstructorP

42 pure $ ADTypeConstructor tConsName tConsArgs

43

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

47 attrAssocs <- braces (sepBy tupleAtomExprP comma)

48 --detect duplicate attribute names

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

50− if not (null dupAttrNames) then

50+ if not (null dupAttrNames) then

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

52 else

53 pure (TupleExpr (M.fromList attrAssocs))

54

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

56tupleAtomExprP = do

57− attributeName <- identifier

57+ attributeName <- attributeNameP

58 atomExpr <- atomExprP

59 pure (attributeName, atomExpr)

60−

60+

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

62projectP = Project <$> braces attributeListP

63

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

65renameClauseP = do

66− oldAttr <- identifier

66+ oldAttr <- attributeNameP

67 reservedOp "as"

68− newAttr <- identifier

68+ newAttr <- attributeNameP

69 pure (oldAttr, newAttr)

70

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

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

74 renameList <- braces (sepBy renameClauseP comma)

75 case renameList of

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

77− renames ->

77+ renames ->

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

79

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

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

84groupClauseP = do

85 attrs <- braces attributeListP

86 reservedOp "as"

87− newAttrName <- identifier

87+ newAttrName <- attributeNameP

88 pure (attrs, newAttrName)

89

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

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

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

98ungroupP = do

99 reservedOp "ungroup"

100− Ungroup <$> identifier

100+ Ungroup <$> attributeNameP

101

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

103extendP = do

104 reservedOp ":"

105 Extend <$> braces extendTupleExpressionP

106−

106+

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

108semijoinP = do

109 reservedOp "semijoin" <|> reservedOp "matching"

110− pure (\exprA exprB ->

110+ pure (\exprA exprB ->

111 Project (RelationalExprAttributeNames exprA) (Join exprA exprB))

112−

112+

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

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

114antijoinP = do

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

116 pure (\exprA exprB ->

117 Difference exprA (

118 Project (RelationalExprAttributeNames exprA) (Join exprA exprB)))

119−

119+

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

121relOperators = [

122 [Postfix projectP],

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

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

137relExprP = try withMacroExprP <|> makeExprParser relTerm relOperators

138

139+--allow for additional characters

140+attributeNameP :: Parser AttributeName

141+attributeNameP = uncapitalizedIdentifier

142+

143+relVarNameP :: Parser RelVarName

144+relVarNameP = uncapitalizedIdentifier

145+

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

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

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

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

141

148

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

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

143relTerm = parens relExprP

150relTerm = parens relExprP

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

158 <|> relationalBooleanExprP

165 <|> relationalBooleanExprP

159

166

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

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

161−relationalBooleanExprP =

168+relationalBooleanExprP =

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

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

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

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

164−

171+

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

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

166restrictionAttributeEqualityP = do

173restrictionAttributeEqualityP = do

167− attributeName <- identifier

174+ attributeName <- attributeNameP

168 reservedOp "="

175 reservedOp "="

169 AttributeEqualityPredicate attributeName <$> atomExprP

176 AttributeEqualityPredicate attributeName <$> atomExprP

170

177

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

181

188

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

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

183attributeExtendTupleExpressionP = do

190attributeExtendTupleExpressionP = do

184− newAttr <- identifier

191+ newAttr <- attributeNameP

185 reservedOp ":="

192 reservedOp ":="

186 AttributeExtendTupleExpr newAttr <$> atomExprP

193 AttributeExtendTupleExpr newAttr <$> atomExprP

187

194

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

199attributeAtomExprP :: Parser (AtomExprBase a)

206attributeAtomExprP :: Parser (AtomExprBase a)

200attributeAtomExprP = do

207attributeAtomExprP = do

201 _ <- string "@"

208 _ <- string "@"

202− AttributeAtomExpr <$> identifier

209+ AttributeAtomExpr <$> attributeNameP

203

210

204nakedAtomExprP :: Parser (AtomExprBase a)

211nakedAtomExprP :: Parser (AtomExprBase a)

205nakedAtomExprP = NakedAtomExpr <$> atomP

212nakedAtomExprP = NakedAtomExpr <$> atomP

206

213

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

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

208constructedAtomExprP consume = do

215constructedAtomExprP consume = do

209− dConsName <- capitalizedIdentifier

216+ dConsName <- dataConstructorNameP

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

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

211 ConstructedAtomExpr dConsName dConsArgs <$> parseMarkerP

218 ConstructedAtomExpr dConsName dConsArgs <$> parseMarkerP

212−

219+

213-- used only for primitive type parsing ?

220-- used only for primitive type parsing ?

214atomP :: Parser Atom

221atomP :: Parser Atom

215−atomP = stringAtomP <|>

222+atomP = stringAtomP <|>

216− doubleAtomP <|>

223+ doubleAtomP <|>

217− integerAtomP <|>

224+ integerAtomP <|>

218 boolAtomP

225 boolAtomP

219−

226+

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

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

221−functionAtomExprP =

228+functionAtomExprP =

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

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

223

230

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

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

225relationalAtomExprP = RelationAtomExpr <$> relExprP

232relationalAtomExprP = RelationAtomExpr <$> relExprP

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

227stringAtomP :: Parser Atom

234stringAtomP :: Parser Atom

228stringAtomP = TextAtom <$> quotedString

235stringAtomP = TextAtom <$> quotedString

229

236

230−doubleAtomP :: Parser Atom

237+doubleAtomP :: Parser Atom

231doubleAtomP = DoubleAtom <$> try float

238doubleAtomP = DoubleAtom <$> try float

232

239

233integerAtomP :: Parser Atom

240integerAtomP :: Parser Atom

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

237boolAtomP = do

244boolAtomP = do

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

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

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

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

240−

247+

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

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

242relationAtomExprP = RelationAtomExpr <$> makeRelationP

249relationAtomExprP = RelationAtomExpr <$> makeRelationP

243

250

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

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

245withMacroExprP = do

252withMacroExprP = do

246 reservedOp "with"

253 reservedOp "with"

247− macros <- parens (sepBy1 createMacroP comma)

254+ views <- parens (sepBy1 createMacroP comma)

248− With macros <$> relExprP

255+ With views <$> relExprP

249

256

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

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

251createMacroP = do

258createMacroP = do

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

254 expr <- relExprP

261 expr <- relExprP

255 marker <- parseMarkerP

262 marker <- parseMarkerP

256 pure (WithNameExpr name marker, expr)

263 pure (WithNameExpr name marker, expr)

257−

264+

265+

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

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

42 reserved "isorestrict"

43 relVarIn <- qrelVarP

44 relvarsOut <- isoRestrictOutRelVarsP

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

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

46

47isoRestrictOutRelVarsP :: Parser (RelVarName, RelVarName)

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

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

55 reserved "isounion"

56 relVarsIn <- isoUnionInRelVarsP

57 relVarsOut <- qrelVarP

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

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

59

60isoRenameP :: Parser SchemaIsomorph

61isoRenameP = do

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

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

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

76evalSchemaOperator 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

9

10instance RelationalMarkerExpr () where

11 parseMarkerP = pure ()

12−

12+

13+typeConstructorNameP :: Parser TypeConstructorName

14+typeConstructorNameP = capitalizedIdentifier

15+

16+dataConstructorNameP :: Parser DataConstructorName

17+dataConstructorNameP = capitalizedIdentifier

18+

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

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

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

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

15typeConstructorDefP :: Parser TypeConstructorDef

21typeConstructorDefP :: Parser TypeConstructorDef

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

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

17

23

18typeVarNamesP :: Parser [TypeVarName]

24typeVarNamesP :: Parser [TypeVarName]

19typeVarNamesP = many uncapitalizedIdentifier

25typeVarNamesP = many uncapitalizedIdentifier

20

26

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

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

22dataConstructorDefP :: Parser DataConstructorDef

28dataConstructorDefP :: Parser DataConstructorDef

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

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

24

30

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

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

26dataConstructorDefArgP :: Parser DataConstructorDefArg

32dataConstructorDefArgP :: Parser DataConstructorDefArg

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

47 monoTypeConstructorP

53 monoTypeConstructorP

48

54

49monoTypeConstructorP :: Parser TypeConstructor

55monoTypeConstructorP :: Parser TypeConstructor

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

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

51 TypeVariable <$> uncapitalizedIdentifier

57 TypeVariable <$> uncapitalizedIdentifier

52

58

53

59

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

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

7import System.IO

8import Options.Applicative

9import System.Exit

10−#if __GLASGOW_HASKELL__ <= 802

10+#if __GLASGOW_HASKELL__ < 804

11import Data.Monoid

12#endif

13import Data.Maybe

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

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

6import TutorialD.Interpreter

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

8import qualified Data.Text as T

9−#if __GLASGOW_HASKELL__ <= 802

9+#if __GLASGOW_HASKELL__ < 804

10import Data.Monoid

11#endif

12import Control.Monad

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

14data HandlesArgs = HandlesArgs {

15 openCloseCount :: Int,

16 transactionCount :: Int,

17− dbdir :: FilePath,

17+ dbdir :: FilePath,

18 tutdSetup :: String,

19 tutdIterate :: String

20 }

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

40main :: IO ()

41main = do

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

43− replicateM_ (openCloseCount args) (runOpenClose

43+ replicateM_ (openCloseCount args) (runOpenClose

44 (T.pack (tutdSetup args))

45 (T.pack (tutdIterate args))

46− (transactionCount args)

46+ (transactionCount args)

47 (dbdir args))

48−

48+

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

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

50runOpenClose tutdSetup' tutdIterate' tCount dbdir' = do

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

52 eConn <- connectProjectM36 connInfo

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

56 eSess <- createSessionAtHead conn "master"

57 case eSess of

58 Left err -> error (show err)

59− Right session ->

59+ Right session ->

60 --database setup

61 case parseTutorialD tutdSetup' of

62 Left err -> error (show err)

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

74 replicateM_ tCount (runTransaction tutdIterate' session conn)

75 close conn

76 printFdCount

77−

77+

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

79−runTransaction tutdIterate' sess conn =

79+runTransaction tutdIterate' sess conn =

80 --run tutd on every iteration

81 case parseTutorialD tutdIterate' of

82 Left err -> error (show err)

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

95 case eErr of

96 Left err -> error (show err)

97 Right _ -> printFdCount

98−

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

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

1−{-# LANGUAGE FlexibleInstances #-}

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

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

3import ProjectM36.Base

4import ProjectM36.Relation

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

9import qualified Data.Text as T

10--import ProjectM36.Relation.Show.CSV

11import ProjectM36.Relation.Show.HTML

12−import TutorialD.Interpreter.DatabaseContextExpr (interpretDatabaseContextExpr)

13import ProjectM36.RelationalExpression

12import ProjectM36.RelationalExpression

14import ProjectM36.TransactionGraph

13import ProjectM36.TransactionGraph

15--import qualified Data.HashSet as HS

14--import qualified Data.HashSet as HS

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

18--import qualified Data.Hashable as Hash

17--import qualified Data.Hashable as Hash

19import qualified Data.Vector as V

18import qualified Data.Vector as V

20import Options.Applicative

19import Options.Applicative

21−import qualified Data.Map as M

22import qualified Data.Text.IO as TIO

20import qualified Data.Text.IO as TIO

23import System.IO

21import System.IO

24−import Control.Monad.State

25import Control.DeepSeq

22import Control.DeepSeq

26import Data.Text hiding (map)

23import Data.Text hiding (map)

27−import Data.Monoid

28import Data.Time.Clock

24import Data.Time.Clock

29−import Data.UUID

30import Data.UUID.V4

25import Data.UUID.V4

26+#if __GLASGOW_HASKELL__ < 804

27+import Data.Monoid

28+#endif

29+

31

30

32{-

31{-

33dumpcsv :: Relation -> IO ()

32dumpcsv :: Relation -> IO ()

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

76 case eNewState of

75 case eNewState of

77 Right newState -> do

76 Right newState -> do

78 let ctx = dbc_context newState

77 let ctx = dbc_context newState

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

79+ env' = RelationalExprEnv ctx graph Nothing

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

80+ TIO.putStrLn $ relationAsHTML x

80 Left err -> hPrint stderr err

81 Left err -> hPrint stderr err

81

82

82{-

83{-

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

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

3import ProjectM36.Error

4import ProjectM36.DataTypes.Interval

5import qualified Data.Text as T

6−#if __GLASGOW_HASKELL__ <= 802

6+#if __GLASGOW_HASKELL__ < 804

7import Data.Monoid

8#endif

9

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

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

1+{-# LANGUAGE CPP #-}

1module ProjectM36.AtomFunction where

2module ProjectM36.AtomFunction where

2import ProjectM36.Base

3import ProjectM36.Base

3import ProjectM36.Error

4import ProjectM36.Error

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

72 retType]])

73 retType]])

73

74

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

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

76+#ifdef PM36_HASKELL_SCRIPTING

75loadAtomFunctions = loadFunction

77loadAtomFunctions = loadFunction

78+#else

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

80+#endif

76

81

77atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation

82atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation

78atomFunctionsAsRelation funcs = mkRelationFromList attrs tups

83atomFunctionsAsRelation funcs = mkRelationFromList attrs tups

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

81 Attribute "arguments" TextAtomType]

86 Attribute "arguments" TextAtomType]

82 atomFuncToTuple aFunc = [TextAtom (atomFuncName aFunc),

87 atomFuncToTuple aFunc = [TextAtom (atomFuncName aFunc),

83 TextAtom (atomFuncTypeToText aFunc)]

88 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

139

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

141-- check that the data constructor names are unique

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

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

143−validateTypeConstructorDef tConsDef dConsList = execWriter $ do

143+validateTypeConstructorDef tConsDef dConsList tConsMap = do

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

145− mapM_ tell [map DataConstructorNameInUseError duplicateDConsNames]

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

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

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

148 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 ()

150

173

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

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

152atomTypeForTypeConstructor = atomTypeForTypeConstructorValidate False

175atomTypeForTypeConstructor = atomTypeForTypeConstructorValidate False

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

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

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

210resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType

233resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType

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

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

212− ConstructedAtomType tConsName <$> resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

235+ ConstructedAtomType tConsName <$> resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

213−resolveAtomType typeFromRelation unresolvedType =

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

214− if typeFromRelation == unresolvedType then

215− Right typeFromRelation

237+ Right typeFromRelation

216− else

238+ else

217− Left (AtomTypeMismatchError typeFromRelation unresolvedType)

239+ Left (AtomTypeMismatchError typeFromRelation unresolvedType)

218

240

219{-

241{-

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

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

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

241 Just unresType -> case unresType of

263 Just unresType -> case unresType of

242 --do we need to recurse for RelationAtomType?

264 --do we need to recurse for RelationAtomType?

243 subType@(ConstructedAtomType _ _) -> do

265 subType@(ConstructedAtomType _ _) -> do

244− resSubType <- resolveAtomType resType subType

266+ resSubType <- resolveAtomType resType subType

245− pure (resKey, resSubType)

267+ pure (resKey, resSubType)

246− typ ->

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

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

269+ typ -> if typ == resType then

248− pure (resKey, typ')

270+ pure (resKey, resType)

271+ else

272+ Left $ AtomTypeMismatchError typ resType

249 Nothing ->

273 Nothing ->

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

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

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

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

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

343

367

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

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

345typeVarMapsVerify :: TypeVarMap -> TypeVarMap -> Bool

369typeVarMapsVerify :: 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)

347

376

348prettyAtomType :: AtomType -> T.Text

377prettyAtomType :: AtomType -> T.Text

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

378prettyAtomType (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

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

57 toAddTypeExpr :: proxy a -> DatabaseContextExpr

58 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))

60

61instance Atomable Integer where

62 toAtom = IntegerAtom

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

148--convert to ADT list

149instance Atomable a => Atomable [a] where

150 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])

152

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

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

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

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

156

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

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

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

185 toAtomG (M1 v) = toAtomG v

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

187− toAtomsG = undefined

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

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

189 where

190 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

192 where

193 tcDef = ADTypeConstructorDef tcName []

194 dataConstructors = getConstructorsG v

195 toAddTypeExprG _ _ = NoOperation

196− getConstructorsG (M1 v) = getConstructorsG v

196+ getConstructorsG ~(M1 v) = getConstructorsG v

197− getConstructorArgsG = undefined

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

198

199--constructor metadata

200instance (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

209 Nothing

210 where

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

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

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

213− toAtomsG = undefined

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

214− toAtomTypeG = undefined

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

215− toAddTypeExprG = undefined

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

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

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

217 where

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

219 dArgs = getConstructorArgsG v

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

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

226 toAtomsG (M1 v) = toAtomsG v

227 toAtomTypeG (M1 v) = toAtomTypeG v

228− toAddTypeExprG _ _ = undefined

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

229− getConstructorsG = undefined

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

230− getConstructorArgsG (M1 v) = getConstructorArgsG v

230+ getConstructorArgsG ~(M1 v) = getConstructorArgsG v

231

232-- field data metadata

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

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

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

238 toAtomsG (K1 v) = [toAtom v]

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

240− toAddTypeExprG _ _ = undefined

240+ toAddTypeExprG = error "invalid toAddTypeExprG in K1"

241− getConstructorsG = undefined

241+ getConstructorsG = error "invalid getConstructorsG in K1"

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

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

243 where

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

245

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

261typeToTypeConstructor (TypeVariableType tvName) = TypeVariable tvName

262

263instance AtomableG U1 where

264− toAtomG = undefined

264+ toAtomG = error "invalid toAtomG in U1"

265 fromAtomG _ _ = pure U1

266 toAtomsG _ = []

267− toAtomTypeG = undefined

267+ toAtomTypeG = error "invalid toAtomTypeG in U1"

268− toAddTypeExprG = undefined

268+ toAddTypeExprG = error "invalid toAddTypeExprG in U1"

269− getConstructorsG = undefined

269+ getConstructorsG = error "invalid getConstructorsG in U1"

270 getConstructorArgsG _ = []

271

272-- product types

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

276 where splitargs1 = take splitpoint args

277 splitargs2 = drop splitpoint args

278 splitpoint = length args `div` 2

279− toAtomTypeG = undefined

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

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

281− toAddTypeExprG _ _ = undefined

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

282− getConstructorsG = undefined

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

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

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

284

285-- sum types

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

287 toAtomG (L1 x) = toAtomG x

288 toAtomG (R1 x) = toAtomG x

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

290− toAtomTypeG = undefined

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

291 toAtomsG (L1 x) = toAtomsG x

292 toAtomsG (R1 x) = toAtomsG x

293− toAddTypeExprG _ _ = undefined

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

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

295− getConstructorArgsG = undefined

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

296

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

298{-

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 #-}

2{-|

3Module: ProjectM36.Client

4

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

137

138import Network.Transport (Transport(closeTransport))

139#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)

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

142#elif MIN_VERSION_network_transport_tcp(0,6,0)

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

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

166import qualified ProjectM36.Session as Sess

167import ProjectM36.Session

168import ProjectM36.Sessions

169−--import "list-t" ListT

170import Data.Binary (Binary)

169import Data.Binary (Binary)

171import GHC.Generics (Generic)

170import GHC.Generics (Generic)

172import Control.DeepSeq (force)

171import Control.DeepSeq (force)

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

275createLocalNode :: IO (LocalNode, Transport)

274createLocalNode :: IO (LocalNode, Transport)

276createLocalNode = do

275createLocalNode = do

277#if MIN_VERSION_network_transport_tcp(0,7,0)

276#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

284#elif MIN_VERSION_network_transport_tcp(0,6,0)

278#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

286#else

280#else

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

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

288#endif

282#endif

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

1199 case verified of

1193 case verified of

1200 Left err -> pure (Left err)

1194 Left err -> pure (Left err)

1201 Right attrs -> do

1195 Right attrs -> do

1196+ let attrOrders = zipWith

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

1197+ (DF.AttributeOrder . attributeName)

1198+ attrs

1199+ orders

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

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

1204 Left err -> pure (Left err)

1201 Left err -> pure (Left err)

1205 Right dFrame -> do

1202 Right dFrame -> do

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

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

18import qualified Data.Text as T

19import Data.Binary

20import Control.Arrow

21−#if __GLASGOW_HASKELL__ <= 802

21+#if __GLASGOW_HASKELL__ < 804

22import Data.Monoid

23#endif

24

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

163 where

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

165 atomAsHTML (RelationAtom rel) = RelHTML.relationAsHTML rel

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

166 atomAsHTML atom = atomToText atom

167 atomAsHTML atom = atomToText atom

167

168

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

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

src/lib/ProjectM36/DatabaseContextFunction.hs+5

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

1+{-# LANGUAGE CPP #-}

1module ProjectM36.DatabaseContextFunction where

2module ProjectM36.DatabaseContextFunction where

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

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

3import ProjectM36.Base

4import ProjectM36.Base

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

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

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

62

63

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

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

65+#ifdef PM36_HASKELL_SCRIPTING

64loadDatabaseContextFunctions = loadFunction

66loadDatabaseContextFunctions = loadFunction

67+#else

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

69+#endif

65

70

66databaseContextFunctionsAsRelation :: DatabaseContextFunctions -> Either RelationalError Relation

71databaseContextFunctionsAsRelation :: DatabaseContextFunctions -> Either RelationalError Relation

67databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups

72databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups

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

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

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

1+{-# LANGUAGE CPP #-}

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

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

4module ProjectM36.FileLock where

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

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

13import qualified Data.Map as M

14import qualified Data.Set as S

15import qualified Data.List as L

16−#if __GLASGOW_HASKELL__ <= 802

16+#if __GLASGOW_HASKELL__ < 804

17import Data.Monoid

18#endif

19−

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

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

21

20

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

21--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

2import ProjectM36.Base

3import ProjectM36.Relation

4import qualified Data.Set as S

5−#if __GLASGOW_HASKELL__ <= 802

5+#if __GLASGOW_HASKELL__ < 804

6import Data.Monoid

7#endif

8

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

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

8import Data.Text (Text, pack)

9import qualified Data.Text as T

10import qualified Data.Text.IO as TIO

11−import qualified Data.Vector as V

12−#if __GLASGOW_HASKELL__ <= 802

11+#if __GLASGOW_HASKELL__ < 804

13import Data.Monoid

12import Data.Monoid

14#endif

13#endif

14+import qualified Data.Vector as V

15

16attributesAsHTML :: Attributes -> Text

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

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

53 where

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

55 atomAsHTML (RelationAtom rel) = relationAsHTML rel

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

56 atomAsHTML atom = atomToText atom

57 atomAsHTML atom = atomToText atom

57

58

58tupleSetAsHTML :: RelationTupleSet -> Text

59tupleSetAsHTML :: RelationTupleSet -> Text

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

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

9import qualified Data.List as L

10import qualified Data.Text as T

11import Control.Arrow hiding (left)

12−#if __GLASGOW_HASKELL__ <= 802

12+#if __GLASGOW_HASKELL__ < 804

13import Data.Monoid

14#endif

15import 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

21import qualified Data.Map as M

22import qualified Data.HashSet as HS

23import qualified Data.Set as S

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

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

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

26−import Control.Exception

27import Data.Maybe

25import Data.Maybe

28import Data.Either

26import Data.Either

29import Data.Char (isUpper)

27import Data.Char (isUpper)

28+import Data.Time

29+import qualified Data.List.NonEmpty as NE

30+import Data.Functor.Identity

30import qualified Data.Text as T

31import qualified Data.Text as T

31import qualified Data.Vector as V

32import qualified Data.Vector as V

32import qualified ProjectM36.TypeConstructorDef as TCD

33import qualified ProjectM36.TypeConstructorDef as TCD

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

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

33import Control.Monad.Except hiding (join)

36import Control.Monad.Except hiding (join)

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

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

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

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

36import ProjectM36.NormalizeExpr

39import ProjectM36.NormalizeExpr

37import ProjectM36.WithNameExpr

40import ProjectM36.WithNameExpr

38import Test.QuickCheck

41import Test.QuickCheck

42+#ifdef PM36_HASKELL_SCRIPTING

39import GHC hiding (getContext)

43import GHC hiding (getContext)

44+import Control.Exception

40import GHC.Paths

45import GHC.Paths

41−import Data.Time.Clock

46+#endif

42−import Data.Time.Calendar

43−import qualified Data.List.NonEmpty as NE

44−import Data.Functor.Identity

45

47

46data DatabaseContextExprDetails = CountUpdatedTuples

48data DatabaseContextExprDetails = CountUpdatedTuples

47

49

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

367 --prevent recursive relvar definition

369 --prevent recursive relvar definition

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

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

369 potentialContext = currentContext { relationVariables = newRelVars }

371 potentialContext = currentContext { relationVariables = newRelVars }

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

370− --determine when to check constraints

376+ --determine when to check constraints

371− graph <- dbcGraph

377+ graph <- dbcGraph

372− tid <- dbcTransId

378+ tid <- dbcTransId

373− case checkConstraints potentialContext tid graph of

379+ case checkConstraints potentialContext tid graph of

374− Left err -> dbErr err

380+ Left err -> dbErr err

375− Right _ -> putStateContext potentialContext

381+ Right _ -> putStateContext potentialContext

376

382

377-- 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

383-- 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

378deleteRelVar :: RelVarName -> DatabaseContextEvalMonad ()

384deleteRelVar :: RelVarName -> DatabaseContextEvalMonad ()

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

520 let oldTypes = typeConstructorMapping currentContext

526 let oldTypes = typeConstructorMapping currentContext

521 tConsName = TCD.name tConsDef

527 tConsName = TCD.name tConsDef

522 -- validate that the constructor's types exist

528 -- validate that the constructor's types exist

523− case validateTypeConstructorDef tConsDef dConsDefList of

529+ case validateTypeConstructorDef tConsDef dConsDefList oldTypes of

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

530+ Left err -> throwError err

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

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

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

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

527 | otherwise -> do

533 | otherwise -> do

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

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

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

598 case evalDatabaseContextFunction func (rights eAtomArgs) context of

604 case evalDatabaseContextFunction func (rights eAtomArgs) context of

599 Left err -> dbErr err

605 Left err -> dbErr err

600 Right newContext -> putStateContext newContext

606 Right newContext -> putStateContext newContext

601−

602data DatabaseContextIOEvalEnv = DatabaseContextIOEvalEnv

607data DatabaseContextIOEvalEnv = DatabaseContextIOEvalEnv

603 { dbcio_transId :: TransactionId,

608 { dbcio_transId :: TransactionId,

604 dbcio_graph :: TransactionGraph,

609 dbcio_graph :: TransactionGraph,

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

638 pure $ mkRelationalExprEnv context (dbcio_graph env)

643 pure $ mkRelationalExprEnv context (dbcio_graph env)

639

644

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

645evalGraphRefDatabaseContextIOExpr :: 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

641evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName funcType script) = do

652evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName funcType script) = do

642 eScriptSession <- requireScriptSession

653 eScriptSession <- requireScriptSession

643 currentContext <- getDBCIOContext

654 currentContext <- getDBCIOContext

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

671 Right eContext -> case eContext of

682 Right eContext -> case eContext of

672 Left err -> pure (Left err)

683 Left err -> pure (Left err)

673 Right context' -> putDBCIOContext context'

684 Right context' -> putDBCIOContext context'

674−

675evalGraphRefDatabaseContextIOExpr (AddDatabaseContextFunction funcName funcType script) = do

685evalGraphRefDatabaseContextIOExpr (AddDatabaseContextFunction funcName funcType script) = do

676 eScriptSession <- requireScriptSession

686 eScriptSession <- requireScriptSession

677 currentContext <- getDBCIOContext

687 currentContext <- getDBCIOContext

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

713 Right eContext -> case eContext of

723 Right eContext -> case eContext of

714 Left err -> pure (Left err)

724 Left err -> pure (Left err)

715 Right context' -> putDBCIOContext context'

725 Right context' -> putDBCIOContext context'

716−

717evalGraphRefDatabaseContextIOExpr (LoadAtomFunctions modName funcName modPath) = do

726evalGraphRefDatabaseContextIOExpr (LoadAtomFunctions modName funcName modPath) = do

718 currentContext <- getDBCIOContext

727 currentContext <- getDBCIOContext

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

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

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

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

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

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

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

732 in putDBCIOContext newContext

741 in putDBCIOContext newContext

733−

734evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs range) = do

742evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs range) = do

735 --Define

743 --Define

736 currentContext <- getDBCIOContext

744 currentContext <- getDBCIOContext

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

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

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

762 Left err -> pure (Left err)

770 Left err -> pure (Left err)

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

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

764−

772+#endif

765{-

773{-

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

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

767updateTupleWithAtomExprs exprMap context graph tupIn = do

775updateTupleWithAtomExprs exprMap context graph tupIn = do

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

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

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

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

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

2+#ifdef PM36_HASKELL_SCRIPTING

3−{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE MagicHash #-}

4#endif

5module ProjectM36.ScriptSession where

6

7+#ifdef PM36_HASKELL_SCRIPTING

7import ProjectM36.Error

8import ProjectM36.Error

8−

9+import GHC

9import Control.Exception

10import Control.Exception

10import Control.Monad

11import Control.Monad

11import System.IO.Error

12import System.IO.Error

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

16import System.Info (os, arch)

17import System.Info (os, arch)

17import Data.Text (Text, unpack)

18import Data.Text (Text, unpack)

18import Data.Maybe

19import Data.Maybe

19−

20−import GHC

21import GHC.Paths (libdir)

20import GHC.Paths (libdir)

22#if __GLASGOW_HASKELL__ >= 800

21#if __GLASGOW_HASKELL__ >= 800

23import GHC.LanguageExtensions

22import GHC.LanguageExtensions

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

36#if __GLASGOW_HASKELL__ >= 802

35#if __GLASGOW_HASKELL__ >= 802

37import Type

36import Type

38#elif __GLASGOW_HASKELL__ >= 710

37#elif __GLASGOW_HASKELL__ >= 710

39−import Type hiding (pprTyThing)

38+import Type hiding (pprTyThing)

40#else

39#else

41#endif

40#endif

42−

43import GHC.Exts (addrToAny#)

41import GHC.Exts (addrToAny#)

44import GHC.Ptr (Ptr(..))

42import GHC.Ptr (Ptr(..))

45import Encoding

43import Encoding

44+#endif

45+

46

47data ScriptSession = ScriptSession {

48+#ifdef PM36_HASKELL_SCRIPTING

48− hscEnv :: HscEnv,

49+ hscEnv :: HscEnv,

49 atomFunctionBodyType :: Type,

50 atomFunctionBodyType :: Type,

50 dbcFunctionBodyType :: Type

51 dbcFunctionBodyType :: Type

52+#endif

51 }

53 }

52−

54+

55+#ifdef PM36_HASKELL_SCRIPTING

53−newtype ScriptSessionError = ScriptSessionLoadError GhcException

56+data ScriptSessionError = ScriptSessionLoadError GhcException

57+ | ScriptingDisabled

54 deriving (Show)

58 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

55

67

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

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

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

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

70+#if !defined(PM36_HASKELL_SCRIPTING)

71+initScriptSession _ = pure (Left ScriptingDisabled)

72+#else

58initScriptSession ghcPkgPaths = do

73initScriptSession ghcPkgPaths = do

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

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

60 eHomeDir <- tryJust (guard . isDoesNotExistError) getHomeDirectory

75 eHomeDir <- tryJust (guard . isDoesNotExistError) getHomeDirectory

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

65 let ghcVersion = projectVersion dflags

80 let ghcVersion = projectVersion dflags

66

81

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

82 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"

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

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

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

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

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

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

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

87 "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",

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

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

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

75 ]

90 ]

76−

91+

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

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

78−

93+

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

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

80− ghcLink = LinkInMemory,

95+ ghcLink = LinkInMemory,

81 safeHaskell = Sf_Trustworthy,

96 safeHaskell = Sf_Trustworthy,

82 safeInfer = True,

97 safeInfer = True,

83 safeInferred = True,

98 safeInferred = True,

84 --verbosity = 3,

99 --verbosity = 3,

85−#if __GLASGOW_HASKELL__ >= 800

100+#if __GLASGOW_HASKELL__ >= 800

86 trustFlags = map TrustPackage required_packages,

101 trustFlags = map TrustPackage required_packages,

87−#endif

102+#endif

88 packageFlags = packageFlags dflags ++ packages,

103 packageFlags = packageFlags dflags ++ packages,

89#if __GLASGOW_HASKELL__ >= 802

104#if __GLASGOW_HASKELL__ >= 802

90 packageDBFlags = map PackageDB localPkgPaths

105 packageDBFlags = map PackageDB localPkgPaths

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

97 applyXopts flags = foldl xopt_set flags xopts

112 applyXopts flags = foldl xopt_set flags xopts

98#if __GLASGOW_HASKELL__ >= 800

113#if __GLASGOW_HASKELL__ >= 800

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

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

100−#else

115+#else

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

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

102#endif

117#endif

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

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

104− required_packages = ["base",

119+ required_packages = ["base",

105 "containers",

120 "containers",

106 "Glob",

121 "Glob",

107 "directory",

122 "directory",

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

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

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

124 _ <- setSessionDynFlags dflags'

139 _ <- setSessionDynFlags dflags'

125 let safeImportDecl mn mQual = ImportDecl {

140 let safeImportDecl mn mQual = ImportDecl {

126−#if __GLASGOW_HASKELL__ >= 802

141+#if __GLASGOW_HASKELL__ >= 802

127 ideclSourceSrc = NoSourceText,

142 ideclSourceSrc = NoSourceText,

128#else

143#else

129 ideclSourceSrc = Nothing,

144 ideclSourceSrc = Nothing,

130#endif

145#endif

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

146+

147+#if __GLASGOW_HASKELL__ >= 806

132− ideclExt = noExt,

148+ ideclExt = NoExt,

133#endif

149#endif

134 ideclName = noLoc mn,

150 ideclName = noLoc mn,

135 ideclPkgQual = Nothing,

151 ideclPkgQual = Nothing,

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

140 ideclAs = mQual,

156 ideclAs = mQual,

141 ideclHiding = Nothing

157 ideclHiding = Nothing

142 }

158 }

159+#if __GLASGOW_HASKELL__ >= 806

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

161+#endif

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

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

144 "Prelude",

163 "Prelude",

145 "Data.Map",

164 "Data.Map",

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

156 mkModName = noLoc . mkModuleName

175 mkModName = noLoc . mkModuleName

157#else

176#else

158 mkModName = mkModuleName

177 mkModName = mkModuleName

159−#endif

178+#endif

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

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

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

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

162 ]

181 ]

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

169addImport :: String -> Ghc ()

188addImport :: String -> Ghc ()

170addImport moduleNam = do

189addImport moduleNam = do

171 ctx <- getContext

190 ctx <- getContext

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

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

173−

192+

174showType :: DynFlags -> Type -> String

193showType :: DynFlags -> Type -> String

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

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

176

195

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

195 mErr <- typeCheckScript funcType script

214 mErr <- typeCheckScript funcType script

196 case mErr of

215 case mErr of

197 Just err -> pure (Left err)

216 Just err -> pure (Left err)

198− Nothing ->

217+ Nothing ->

199 --catch exception here

218 --catch exception here

200 --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.

219 --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.

201 -- we can't use dynCompileExpr here because

220 -- we can't use dynCompileExpr here because

202 Right . unsafeCoerce <$> compileExpr sScript

221 Right . unsafeCoerce <$> compileExpr sScript

203−

222+

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

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

205typeCheckScript expectedType inp = do

224typeCheckScript expectedType inp = do

206− dflags <- getSessionDynFlags

225+ dflags <- getSessionDynFlags

207 --catch exception for SyntaxError

226 --catch exception for SyntaxError

208#if __GLASGOW_HASKELL__ >= 802

227#if __GLASGOW_HASKELL__ >= 802

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

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

210−#else

229+#else

211 funcType <- GHC.exprType (unpack inp)

230 funcType <- GHC.exprType (unpack inp)

212#endif

231#endif

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

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

214 if eqType funcType expectedType then

233 if eqType funcType expectedType then

215 pure Nothing

234 pure Nothing

216 else

235 else

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

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

218−

237+

219mangleSymbol :: Maybe String -> String -> String -> String

238mangleSymbol :: Maybe String -> String -> String -> String

220mangleSymbol pkg module' valsym =

239mangleSymbol pkg module' valsym =

221 prefixUnderscore ++

240 prefixUnderscore ++

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

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

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

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

224−

225−type ModName = String

226−type FuncName = String

227−

228−data LoadSymbolError = LoadSymbolError

229

243

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

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

231loadFunction modName funcName objPath = do

245loadFunction modName funcName objPath = do

232−#if __GLASGOW_HASKELL__ >= 802

246+#if __GLASGOW_HASKELL__ >= 802

233 initObjLinker RetainCAFs

247 initObjLinker RetainCAFs

234#else

248#else

235 initObjLinker

249 initObjLinker

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

241 Nothing -> pure (Left LoadSymbolError)

255 Nothing -> pure (Left LoadSymbolError)

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

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

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

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

244−

258+

245−prefixUnderscore :: String

259+prefixUnderscore :: String

246prefixUnderscore =

260prefixUnderscore =

247 case (os,arch) of

261 case (os,arch) of

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

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

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

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

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

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

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

253 _ -> ""

267 _ -> ""

268+#endif

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

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

9

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

11#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)

13#else

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

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

15#endif

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

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

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

59 --unhandledMessagePolicy = Log

60 }

61 where

62− testModeHandlers = if not testBool then

63− []

64− else

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

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

66−

67

63

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

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

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

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

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

122 let hostname = bindHost daemonConfig

118 let hostname = bindHost daemonConfig

123 port = bindPort daemonConfig

119 port = bindPort daemonConfig

124#if MIN_VERSION_network_transport_tcp(0,7,0)

120#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

131#elif MIN_VERSION_network_transport_tcp(0,6,0)

122#elif MIN_VERSION_network_transport_tcp(0,6,0)

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

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

133#else

124#else

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

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

1+{-# LANGUAGE MonoLocalBinds #-}

1module ProjectM36.Server.EntryPoints where

2module ProjectM36.Server.EntryPoints where

2import ProjectM36.Base hiding (inclusionDependencies)

3import ProjectM36.Base hiding (inclusionDependencies)

3import ProjectM36.IsomorphicSchema

4import ProjectM36.IsomorphicSchema

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

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

3import ProjectM36.Client

4import Options.Applicative

5import ProjectM36.Server.Config

6−#if __GLASGOW_HASKELL__ <= 802

6+#if __GLASGOW_HASKELL__ < 804

7import Data.Monoid

8#endif

9

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

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

14import ProjectM36.Relation

15import ProjectM36.Error

16import qualified Data.UUID as U

17−import qualified Control.Foldl as Foldl

18#if MIN_VERSION_stm_containers(1,0,0)

17#if MIN_VERSION_stm_containers(1,0,0)

18+import qualified Control.Foldl as Foldl

19import qualified DeferredFolds.UnfoldlM as UF

20+#else

21+import "list-t" ListT

20#endif

22#endif

21

23

22type Sessions = StmMap.Map SessionId Session

24type Sessions = StmMap.Map SessionId Session

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

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

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

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

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

47 Attribute "parentCommit" TextAtomType]) atomMatrix

49 Attribute "parentCommit" TextAtomType]) atomMatrix

48−

49−

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

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

1+{-# LANGUAGE TypeApplications #-}

1module ProjectM36.Transaction.Persist where

2module ProjectM36.Transaction.Persist where

2import ProjectM36.Base

3import ProjectM36.Base

3import ProjectM36.Error

4import ProjectM36.Error

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

8import qualified Data.Map as M

9import qualified Data.Map as M

9import qualified Data.HashSet as HS

10import qualified Data.HashSet as HS

10import qualified Data.Binary as B

11import qualified Data.Binary as B

11−--import qualified Data.ByteString as BS

12import System.FilePath

13import System.Directory

14import qualified Data.Text as T

15import Control.Monad

16import ProjectM36.ScriptSession

17import ProjectM36.AtomFunctions.Basic (precompiledAtomFunctions)

18−import Control.Exception

18+

19+#ifdef PM36_HASKELL_SCRIPTING

19import GHC

20import GHC

21+import Control.Exception

20import GHC.Paths

22import GHC.Paths

23+#endif

21

24

22getDirectoryNames :: FilePath -> IO [FilePath]

25getDirectoryNames :: FilePath -> IO [FilePath]

23getDirectoryNames path =

26getDirectoryNames path =

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

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

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

118

121

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

122loadAtomFunc :: 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

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

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

122 Nothing -> case atomFunctionForName funcName precompiledFuncs of

125 Nothing -> case atomFunctionForName funcName precompiledFuncs of

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

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

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

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

125 Right realFunc -> pure realFunc

128 Right realFunc -> pure realFunc

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

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

127− Just funcScript ->

130+ Just _funcScript ->

128− case mScriptSession of

131+#ifdef PM36_HASKELL_SCRIPTING

132+ case _mScriptSession of

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

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

130 Just scriptSession -> do

134 Just scriptSession -> do

131 --risk of GHC exception during compilation here

135 --risk of GHC exception during compilation here

132 eCompiledScript <- runGhc (Just libdir) $ do

136 eCompiledScript <- runGhc (Just libdir) $ do

133 setSession (hscEnv scriptSession)

137 setSession (hscEnv scriptSession)

134− compileScript (atomFunctionBodyType scriptSession) funcScript

138+ compileScript (atomFunctionBodyType scriptSession) _funcScript

135 case eCompiledScript of

139 case eCompiledScript of

136 Left err -> throwIO err

140 Left err -> throwIO err

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

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

138− atomFuncType = funcType,

142+ atomFuncType = _funcType,

139− atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript }

143+ atomFuncBody = AtomFunctionBody (Just _funcScript) compiledScript }

144+#else

145+ error "Haskell scripting is disabled"

146+#endif

140

147

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

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

142

149

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

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

151+#if !defined(PM36_HASKELL_SCRIPTING)

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

153+#else

144readAtomFunc transDir funcName mScriptSession precompiledFuncs = do

154readAtomFunc transDir funcName mScriptSession precompiledFuncs = do

145 let atomFuncPath = atomFuncsPath transDir

155 let atomFuncPath = atomFuncsPath transDir

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

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

147 case mFuncScript of

157 case mFuncScript of

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

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

149 Nothing -> case atomFunctionForName funcName precompiledFuncs of

159 Nothing -> case atomFunctionForName funcName precompiledFuncs of

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

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

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

152 Right realFunc -> pure realFunc

162 Right realFunc -> pure realFunc

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

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

154− Just funcScript ->

164+ Just funcScript ->

165+

155 case mScriptSession of

166 case mScriptSession of

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

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

157 Just scriptSession -> do

168 Just scriptSession -> do

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

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

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

165 atomFuncType = funcType,

176 atomFuncType = funcType,

166 atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript }

177 atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript }

178+#endif

167

179

168

180

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

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

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

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

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

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

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

184

196

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

186readDBCFunc transDir funcName mScriptSession precompiledFuncs = do

201readDBCFunc transDir funcName mScriptSession precompiledFuncs = do

202+#endif

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

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

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

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

189 case mFuncScript of

205 case mFuncScript of

190 Nothing -> case databaseContextFunctionForName funcName precompiledFuncs of

206 Nothing -> case databaseContextFunctionForName funcName precompiledFuncs of

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

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

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

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

193− Just funcScript ->

209+ Just _funcScript ->

210+#ifdef PM36_HASKELL_SCRIPTING

194 case mScriptSession of

211 case mScriptSession of

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

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

196 Just scriptSession -> do

213 Just scriptSession -> do

197 eCompiledScript <- runGhc (Just libdir) $ do

214 eCompiledScript <- runGhc (Just libdir) $ do

198 setSession (hscEnv scriptSession)

215 setSession (hscEnv scriptSession)

199− compileScript (dbcFunctionBodyType scriptSession) funcScript

216+ compileScript (dbcFunctionBodyType scriptSession) _funcScript

200 case eCompiledScript of

217 case eCompiledScript of

201 Left err -> throwIO err

218 Left err -> throwIO err

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

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

203− dbcFuncType = funcType,

220+ dbcFuncType = _funcType,

204− dbcFuncBody = DatabaseContextFunctionBody (Just funcScript) compiledScript}

221+ dbcFuncBody = DatabaseContextFunctionBody (Just _funcScript) compiledScript}

222+#else

223+ error "Haskell scripting is disabled"

224+#endif

205

225

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

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

207writeIncDep sync transDir (incDepName, incDep) =

227writeIncDep 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 #-}

2module ProjectM36.TransactionGraph where

3import ProjectM36.Base

4import ProjectM36.Error

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

24import GHC.Generics

25import Data.Binary

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

27+#if __GLASGOW_HASKELL__ < 804

28+import Data.Monoid

29+#endif

27import Control.Arrow

30import Control.Arrow

28import Data.Maybe

31import Data.Maybe

29import Data.UUID.V4

32import Data.UUID.V4

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

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

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

516backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do

519backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do

517 trans <- transactionForId currentTid graph

520 trans <- transactionForId currentTid graph

521+

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

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

519− if length parentIds' < 1 then

523+ case parentIds' of

520− Left RootTransactionTraversalError

524+ [] -> Left RootTransactionTraversalError

521− else do

525+ firstParentId:_ -> do

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

526+ parentTrans <- transactionForId firstParentId graph

523− if steps == 1 then

527+ if steps == 1 then

524− pure (transactionId parentTrans)

528+ pure (transactionId parentTrans)

525− else

529+ else

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

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

527

531

528backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do

532backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do

529 trans <- transactionForId currentTid graph

533 trans <- transactionForId currentTid graph

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

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

24import qualified Data.ByteString as BS

25import qualified Data.Text.Encoding as TE

26import Data.ByteString (ByteString)

27+#if __GLASGOW_HASKELL__ < 804

28+import Data.Monoid

29+#endif

27import qualified Crypto.Hash.SHA256 as SHA256

30import qualified Crypto.Hash.SHA256 as SHA256

28import Control.Arrow

31import Control.Arrow

29import Data.Time.Clock

32import Data.Time.Clock

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

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

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE UndecidableInstances #-}

7+{-# LANGUAGE CPP #-}

7

8

8module ProjectM36.Tupleable where

9module ProjectM36.Tupleable where

9

10

10import Data.Foldable

11import Data.Foldable

11import Data.List (partition)

12import Data.List (partition)

12import qualified Data.Map as Map

13import qualified Data.Map as Map

14+#if __GLASGOW_HASKELL__ < 804

13−--import Data.Monoid

15+import Data.Monoid

16+#endif

14import Data.Proxy

17import Data.Proxy

15import qualified Data.Text as T

18import qualified Data.Text as T

16import qualified Data.Vector as V

19import qualified Data.Vector as V

stack.ghc8.4.yaml+7−12

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

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

3

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-12.11

5+resolver: lts-12.26

6

7# Local packages, usually specified by relative directory name

8packages:

9- '.'

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

11extra-deps:

12−- data-accessor-transformers-0.2.1.7

13−- data-interval-1.2.0

12+- data-interval-1.3.0

14−- extended-reals-0.2.1.0

13+- extended-reals-0.2.3.0

15−- gnuplot-0.5.5.3

16−- aeson-1.2.1.00

17- distributed-process-0.7.4

14- distributed-process-0.7.4

18−- distributed-process-async-0.2.4.1

15+- distributed-process-async-0.2.6

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

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

20−- distributed-process-extras-0.3.2

17+- distributed-process-extras-0.3.5

21−#- deferred-folds-0.9.7.1

22- rset-1.0.0

18- rset-1.0.0

23- hashable-time-0.2.0.2

19- hashable-time-0.2.0.2

24- network-transport-tcp-0.6.0

20- network-transport-tcp-0.6.0

25

21

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

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

27−flags:

23+flags:

28 project-m36:

24 project-m36:

29 stack: true

25 stack: true

30

26

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

50# compiler-check: newer-minor

46# compiler-check: newer-minor

51

47

52allow-newer: true

48allow-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/

3+

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

6+

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/

3+

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

6+

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 @@

1--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 #-}

3import Test.HUnit

4import ProjectM36.Client

5import Data.Binary

@@ -48,6 +48,11 @@ data Test7T = Test7C (Either Integer Integer)

48data Test8T = Test8C Test1T

49 deriving (Show, Generic, Eq, Binary, NFData, Atomable)

50

51+data User = User

52+ { userFirstName :: Text

53+ , userLastName :: Text

54+ } deriving (Eq, Ord, Show, Generic, NFData, Binary, Atomable)

55+

51data Test9_4T = Test9_4C {

56data Test9_4T = Test9_4C {

52 f9_41 :: Int,

57 f9_41 :: Int,

53 f9_42 :: Int,

58 f9_42 :: Int,

@@ -64,15 +69,13 @@ data Test9_5T = Test9_5C {

64 }

69 }

65 deriving (Show, Generic, Eq, Binary, NFData, Atomable)

70 deriving (Show, Generic, Eq, Binary, NFData, Atomable)

66

71

67−

68main :: IO ()

72main :: IO ()

69main = do

73main = do

70 tcounts <- runTestTT testList

74 tcounts <- runTestTT testList

71 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

75 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

72

76

73testList :: Test

77testList :: Test

74−testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testListInstance, testNonEmptyInstance, testADT6Maybe, testADT7Either, testNonPrimitiveValues, testManyFields]

78+testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testSimpleList, testListInstance, testNonEmptyInstance, testADT6Maybe, testADT7Either, testNonPrimitiveValues, testRecordType, testManyFields]

75−

76

79

77-- test some basic data types like int, day, etc.

80-- test some basic data types like int, day, etc.

78testBasicMarshaling :: Test

81testBasicMarshaling :: Test

@@ -157,6 +160,12 @@ testListInstance = TestCase $ do

157 let example = TestListC [3,4,5]

160 let example = TestListC [3,4,5]

158 assertEqual "List instance" example (fromAtom (toAtom example))

161 assertEqual "List instance" example (fromAtom (toAtom example))

159

162

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+

160testNonEmptyInstance :: Test

169testNonEmptyInstance :: Test

161testNonEmptyInstance = TestCase $ do

170testNonEmptyInstance = TestCase $ do

162 let example = TestNonEmptyC [3,4,5]

171 let example = TestNonEmptyC [3,4,5]

@@ -167,6 +176,16 @@ testNonPrimitiveValues = TestCase $ do

167 let example = Test8C (Test1C 3)

176 let example = Test8C (Test1C 3)

168 assertEqual "non-primitive values" example (fromAtom (toAtom example))

177 assertEqual "non-primitive values" example (fromAtom (toAtom example))

169

178

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+

170--test both odd and even product types with more than 2 fields

189--test both odd and even product types with more than 2 fields

171testManyFields :: Test

190testManyFields :: Test

172testManyFields = TestCase $ do

191testManyFields = TestCase $ do

test/Relation/Basic.hs+1−1

@@ -64,7 +64,7 @@ validateAttrTypesMatchTupleAttrTypes rel@(Relation attrs tupSet) = foldr (\tuple

64 tupleAtomCheck tuple = V.all (== True) (attrChecks tuple)

65 attrChecks tuple = V.map (\attr -> case atomForAttributeName (A.attributeName attr) tuple of

66 Left _ -> False

67− Right atom -> (Right $ atomTypeForAtom atom) ==

67+ Right atom -> Right (atomTypeForAtom atom) ==

68 A.atomTypeForAttributeName (A.attributeName attr) attrs) (attributes rel)

69

70simpleRel :: Relation

test/Relation/Export/CSV.hs+23−18

@@ -1,3 +1,5 @@

1+{-# LANGUAGE CPP #-}

2+

1import ProjectM36.Base

3import ProjectM36.Base

2import ProjectM36.Relation.Show.CSV

4import ProjectM36.Relation.Show.CSV

3import ProjectM36.Relation.Parse.CSV

5import ProjectM36.Relation.Parse.CSV

@@ -11,7 +13,11 @@ import System.Exit

11import Test.HUnit

13import Test.HUnit

12import Data.Time.Calendar

14import Data.Time.Calendar

13import Data.Time.Clock

15import Data.Time.Clock

16+

17+#if __GLASGOW_HASKELL__ < 804

14import Data.Monoid

18import Data.Monoid

19+#endif

20+

15{-

21{-

16import qualified Data.Text.Lazy as TL

22import qualified Data.Text.Lazy as TL

17import qualified Data.Text.Lazy.Encoding as TE

23import qualified Data.Text.Lazy.Encoding as TE

@@ -19,9 +25,9 @@ import ProjectM36.Relation.Show.Term

19import qualified Data.ByteString.Lazy as BS

25import qualified Data.ByteString.Lazy as BS

20-}

26-}

21

27

22−main :: IO ()

28+main :: IO ()

23−main = do

29+main = do

24− tcounts <- runTestTT $ TestList [testCSVExport,

30+ tcounts <- runTestTT $ TestList [testCSVExport,

25 testADTExport]

31 testADTExport]

26 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

32 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

27

33

@@ -31,8 +37,8 @@ assertEither x = do

31 case res of

37 case res of

32 Left err -> assertFailure (show err) >> undefined

38 Left err -> assertFailure (show err) >> undefined

33 Right val -> pure val

39 Right val -> pure val

34−

40+

35−testADTExport :: Test

41+testADTExport :: Test

36testADTExport = TestCase $ do

42testADTExport = TestCase $ do

37 let adtCSV = "a\nCons 4 (Cons 5 Empty)\n"

43 let adtCSV = "a\nCons 4 (Cons 5 Empty)\n"

38 attrs = A.attributesFromList [Attribute "a" (listAtomType IntegerAtomType)]

44 attrs = A.attributesFromList [Attribute "a" (listAtomType IntegerAtomType)]

@@ -40,17 +46,17 @@ testADTExport = TestCase $ do

40 case csvAsRelation attrs basicTypeConstructorMapping adtCSV of

46 case csvAsRelation attrs basicTypeConstructorMapping adtCSV of

41 Left err -> assertFailure ("import failure: " <> show err)

47 Left err -> assertFailure ("import failure: " <> show err)

42 Right rel -> assertEqual "import cons list" expectedRel (Right rel)

48 Right rel -> assertEqual "import cons list" expectedRel (Right rel)

43−

49+

44--round-trip various atom types through CSV export/import

50--round-trip various atom types through CSV export/import

45testCSVExport :: Test

51testCSVExport :: Test

46testCSVExport = TestCase $ do

52testCSVExport = TestCase $ do

47 now <- getCurrentTime

53 now <- getCurrentTime

48− testInterval <- assertEither $ pure (createInterval

54+ testInterval <- assertEither $ pure (createInterval

49− (DateTimeAtom now)

55+ (DateTimeAtom now)

50 (DateTimeAtom (addUTCTime 86400 now))

56 (DateTimeAtom (addUTCTime 86400 now))

51 True

57 True

52 False)

58 False)

53− let attrs = A.attributesFromList [Attribute "textattr" TextAtomType,

59+ let attrs = A.attributesFromList [Attribute "textattr" TextAtomType,

54 Attribute "integerattr" IntegerAtomType,

60 Attribute "integerattr" IntegerAtomType,

55 Attribute "dayattr" DayAtomType,

61 Attribute "dayattr" DayAtomType,

56 Attribute "datetimeattr" DateTimeAtomType,

62 Attribute "datetimeattr" DateTimeAtomType,

@@ -61,8 +67,8 @@ testCSVExport = TestCase $ do

61 ]

67 ]

62 sampleByteString = "\1\0\244\34\150"

68 sampleByteString = "\1\0\244\34\150"

63 relOrErr = mkRelationFromList attrs [

69 relOrErr = mkRelationFromList attrs [

64− [TextAtom "text atom with \"quote\"",

70+ [TextAtom "text atom with \"quote\"",

65− IntegerAtom 123,

71+ IntegerAtom 123,

66 DayAtom (fromGregorian 2017 4 10),

72 DayAtom (fromGregorian 2017 4 10),

67 DateTimeAtom now,

73 DateTimeAtom now,

68 ByteStringAtom sampleByteString,

74 ByteStringAtom sampleByteString,

@@ -70,19 +76,19 @@ testCSVExport = TestCase $ do

70 listCons TextAtomType [TextAtom "text1", TextAtom "text2"],

76 listCons TextAtomType [TextAtom "text1", TextAtom "text2"],

71 testInterval

77 testInterval

72 ],

78 ],

73− [TextAtom "second text atom with 漢字",

79+ [TextAtom "second text atom with 漢字",

74− IntegerAtom 314,

80+ IntegerAtom 314,

75 DayAtom (fromGregorian 1001 6 28),

81 DayAtom (fromGregorian 1001 6 28),

76 DateTimeAtom (addUTCTime 360 now),

82 DateTimeAtom (addUTCTime 360 now),

77− ByteStringAtom sampleByteString,

83+ ByteStringAtom sampleByteString,

78 listCons IntegerAtomType [IntegerAtom 10, IntegerAtom 11, IntegerAtom 12],

84 listCons IntegerAtomType [IntegerAtom 10, IntegerAtom 11, IntegerAtom 12],

79 listCons TextAtomType [TextAtom "text5\"", TextAtom "text6\r\n"],

85 listCons TextAtomType [TextAtom "text5\"", TextAtom "text6\r\n"],

80 testInterval

86 testInterval

81 ]]

87 ]]

82−

88+

83− case relOrErr of

89+ case relOrErr of

84 Left err -> assertFailure $ "export relation creation failure: " ++ show err

90 Left err -> assertFailure $ "export relation creation failure: " ++ show err

85− Right rel ->

91+ Right rel ->

86 case relationAsCSV rel of

92 case relationAsCSV rel of

87 Left err -> assertFailure $ "export failed: " ++ show err

93 Left err -> assertFailure $ "export failed: " ++ show err

88 Right csvData ->

94 Right csvData ->

@@ -91,4 +97,3 @@ testCSVExport = TestCase $ do

91 case csvAsRelation attrs basicTypeConstructorMapping csvData of -- import csv data back to relation

97 case csvAsRelation attrs basicTypeConstructorMapping csvData of -- import csv data back to relation

92 Left err -> assertFailure $ "re-import failed: " ++ show err

98 Left err -> assertFailure $ "re-import failed: " ++ show err

93 Right rel' -> assertEqual "relation CSV comparison" rel rel'

99 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 #-}

2import Test.HUnit

3import ProjectM36.Tupleable

4import ProjectM36.Atomable

test/Server/Main.hs+2−1

@@ -94,7 +94,8 @@ launchTestServer ti = do

94 persistenceStrategy = CrashSafePersistence (tempdir </> "db"),

95 perRequestTimeout = ti,

96 testMode = True,

97− bindPort = 0

97+ bindPort = 0,

98+ checkFS = False --not stricly needed for these tests

98 }

99 }

99

100

100 launchServer config (Just addressMVar) >> pure ()

101 launchServer config (Just addressMVar) >> pure ()

test/Server/WebSocket.hs+2−1

@@ -32,7 +32,8 @@ launchTestServer :: IO (PortNumber, DatabaseName)

32launchTestServer = do

33 addressMVar <- newEmptyMVar

34 let config = defaultServerConfig { databaseName = testDatabaseName,

35− bindPort = 0 }

35+ bindPort = 0,

36+ checkFS = False}

36 testDatabaseName = "test"

37 testDatabaseName = "test"

37 -- start normal server

38 -- start normal server

38 _ <- forkIO (launchServer config (Just addressMVar) >> pure ())

39 _ <- forkIO (launchServer config (Just addressMVar) >> pure ())

test/TransactionGraph/Persist.hs+11−4

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

1+{-# LANGUAGE CPP #-}

1import Test.HUnit

2import Test.HUnit

2import ProjectM36.Base

3import ProjectM36.Base

3import ProjectM36.Persist (DiskSync(NoDiskSync))

4import ProjectM36.Persist (DiskSync(NoDiskSync))

@@ -5,8 +6,6 @@ import ProjectM36.TransactionGraph.Persist

5import ProjectM36.TransactionGraph

6import ProjectM36.TransactionGraph

6import ProjectM36.Transaction

7import ProjectM36.Transaction

7import ProjectM36.DateExamples

8import ProjectM36.DateExamples

8−import ProjectM36.Client

9−import ProjectM36.Relation

10import System.IO.Temp

9import System.IO.Temp

11import System.Exit

10import System.Exit

12import Data.Either

11import Data.Either

@@ -17,6 +16,10 @@ import qualified Data.Map as M

17import qualified Data.Set as S

16import qualified Data.Set as S

18import Data.Time.Clock

17import Data.Time.Clock

19import Data.Time.Calendar

18import Data.Time.Calendar

19+#ifdef PM36_HASKELL_SCRIPTING

20+import ProjectM36.Client

21+import ProjectM36.Relation

22+#endif

20

23

21main :: IO ()

24main :: IO ()

22main = do

25main = do

@@ -75,7 +78,10 @@ testDBSimplePersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \temp

75

78

76--only Haskell-scripted dbc and atom functions can be serialized

79--only Haskell-scripted dbc and atom functions can be serialized

77testFunctionPersistence :: Test

80testFunctionPersistence :: Test

81+#if !defined(PM36_HASKELL_SCRIPTING)

78−testFunctionPersistence = TestCase $

82+testFunctionPersistence = TestCase $ pure ()

83+#else

84+testFunctionPersistence = TestCase $

79 withSystemTempDirectory "m36testdb" $ \tempdir -> do

85 withSystemTempDirectory "m36testdb" $ \tempdir -> do

80 let dbdir = tempdir </> "dbdir"

86 let dbdir = tempdir </> "dbdir"

81 connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []

87 connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []

@@ -96,10 +102,11 @@ testFunctionPersistence = TestCase $

96 res <- executeRelationalExpr sess2 conn2 (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (M.singleton "a" (FunctionAtomExpr "testdisk" [NakedAtomExpr (IntAtom 3)] ()))]))

102 res <- executeRelationalExpr sess2 conn2 (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (M.singleton "a" (FunctionAtomExpr "testdisk" [NakedAtomExpr (IntAtom 3)] ()))]))

97 let expectedRel = mkRelationFromList (attributesFromList [Attribute "a" IntAtomType]) [[IntAtom 3]]

103 let expectedRel = mkRelationFromList (attributesFromList [Attribute "a" IntAtomType]) [[IntAtom 3]]

98 assertEqual "testdisk dbc function run" expectedRel res

104 assertEqual "testdisk dbc function run" expectedRel res

99−

105+

100assertIOEither :: (Show a) => IO (Either a b) -> IO b

106assertIOEither :: (Show a) => IO (Either a b) -> IO b

101assertIOEither x = do

107assertIOEither x = do

102 ret <- x

108 ret <- x

103 case ret of

109 case ret of

104 Left err -> assertFailure (show err) >> undefined

110 Left err -> assertFailure (show err) >> undefined

105 Right val -> pure val

111 Right val -> pure val

112+#endif

test/TutorialD/Interpreter.hs+30−4

@@ -75,7 +75,10 @@ main = do

75 testNonEmptyListType,

76 testUnresolvedAtomTypes,

77 testWithClause,

78− testAtomFunctionArgumentMismatch

78+ testAtomFunctionArgumentMismatch,

79+ testInvalidDataConstructor,

80+ testBasicList,

81+ testRelationDeclarationMismatch

79 ]

82 ]

80

83

81simpleRelTests :: Test

84simpleRelTests :: Test

@@ -491,16 +494,22 @@ testEmptyCommits = TestCase $ do

491 assertEqual "empty insert empty commit" (Right False) dirty'

494 assertEqual "empty insert empty commit" (Right False) dirty'

492 Right () <- commit sessionId dbconn

495 Right () <- commit sessionId dbconn

493

496

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

495 Right () <- executeDatabaseContextExpr sessionId dbconn (Update "s" (M.singleton "sname" (NakedAtomExpr (TextAtom "Bob"))) (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))

498 Right () <- executeDatabaseContextExpr sessionId dbconn (Update "s" (M.singleton "sname" (NakedAtomExpr (TextAtom "Bob"))) (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))

496 dirty'' <- disconnectedTransactionIsDirty sessionId dbconn

499 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

498 Right () <- commit sessionId dbconn

507 Right () <- commit sessionId dbconn

499

508

500 --delete no tuples

509 --delete no tuples

501 Right () <- executeDatabaseContextExpr sessionId dbconn (Delete "s" (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))

510 Right () <- executeDatabaseContextExpr sessionId dbconn (Delete "s" (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))

502 dirty''' <- disconnectedTransactionIsDirty sessionId dbconn

511 dirty''' <- disconnectedTransactionIsDirty sessionId dbconn

503− assertEqual "empty delete empty commit" (Right False) dirty'''

512+ assertEqual "empty delete empty commit" (Right True) dirty'''

504

513

505testIntervalAtom :: Test

514testIntervalAtom :: Test

506testIntervalAtom = TestCase $ do

515testIntervalAtom = TestCase $ do

@@ -665,3 +674,20 @@ testAtomFunctionArgumentMismatch = TestCase $ do

665 --wrong argument count

674 --wrong argument count

666 let err2 = "FunctionArgumentCountMismatchError"

675 let err2 = "FunctionArgumentCountMismatchError"

667 expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "x:=relation{tuple{a 5}} where ^gt(@a,1,3)"

676 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 #-}

2import System.Exit

3import Test.HUnit

4+#ifdef PM36_HASKELL_SCRIPTING

5+import TutorialD.Interpreter.TestBase

4import ProjectM36.Client

6import ProjectM36.Client

5import ProjectM36.Relation

7import ProjectM36.Relation

6import ProjectM36.DataTypes.Maybe

8import ProjectM36.DataTypes.Maybe

7import qualified Data.Vector as V

9import qualified Data.Vector as V

8import qualified Data.Map as M

10import qualified Data.Map as M

11+#endif

9

12

10{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

13{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

11main :: IO ()

14main :: IO ()

12main = do

15main = do

13− tcounts <- runTestTT (TestList [testBasicAtomFunction,

16+ tcounts <- runTestTT (TestList [

17+#ifdef PM36_HASKELL_SCRIPTING

18+ testBasicAtomFunction,

14− testExceptionAtomFunction,

19+ testExceptionAtomFunction,

15− testErrorAtomFunction,

20+ testErrorAtomFunction,

16− testNoArgumentAtomFunction,

21+ testNoArgumentAtomFunction,

17− testArgumentTypeMismatch,

22+ testArgumentTypeMismatch,

18− testPolymorphicReturnType,

23+ testPolymorphicReturnType,

19− testScriptedTypeVariable

24+ testScriptedTypeVariable

25+#endif

20− ])

26+ ])

21 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

27 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

22

28

29+#ifdef PM36_HASKELL_SCRIPTING

23--add an atom function and run it

30--add an atom function and run it

24testBasicAtomFunction :: Test

31testBasicAtomFunction :: Test

25testBasicAtomFunction = TestCase $ do

32testBasicAtomFunction = TestCase $ do

@@ -112,3 +119,4 @@ testScriptedTypeVariable = TestCase $ do

112

119

113 assertEqual "id function equality" expectedResult result

120 assertEqual "id function equality" expectedResult result

114

121

122+#endif

test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs+13−6

@@ -1,19 +1,26 @@

1−import TutorialD.Interpreter.TestBase

1+{-# LANGUAGE CPP #-}

2import System.Exit

3import Test.HUnit

4+#ifdef PM36_HASKELL_SCRIPTING

5+import TutorialD.Interpreter.TestBase

4import ProjectM36.Client

6import ProjectM36.Client

5import ProjectM36.Relation

7import ProjectM36.Relation

6import qualified Data.Text as T

8import qualified Data.Text as T

9+#endif

7

10

8main :: IO ()

11main :: IO ()

9main = do

12main = do

10− tcounts <- runTestTT (TestList [testBasicDBCFunction,

13+ tcounts <- runTestTT (TestList [

14+#ifdef PM36_HASKELL_SCRIPTING

15+ testBasicDBCFunction,

11− testErrorDBCFunction,

16+ testErrorDBCFunction,

12− testExceptionDBCFunction,

17+ testExceptionDBCFunction,

13− testDBCFunctionWithAtomArguments

18+ testDBCFunctionWithAtomArguments

19+#endif

14 ])

20 ])

15 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

21 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

16

22

23+#ifdef PM36_HASKELL_SCRIPTING

17testBasicDBCFunction :: Test

24testBasicDBCFunction :: Test

18testBasicDBCFunction = TestCase $ do

25testBasicDBCFunction = TestCase $ do

19 (sess, conn) <- dateExamplesConnection emptyNotificationCallback

26 (sess, conn) <- dateExamplesConnection emptyNotificationCallback

@@ -55,4 +62,4 @@ testDBCFunctionWithAtomArguments = TestCase $ do

55 assertEqual "person relation" expectedPerson result

62 assertEqual "person relation" expectedPerson result

56 expectTutorialDErr sess conn (T.isPrefixOf "AtomTypeMismatchError") "execute multiArgFunc(\"fail\", \"fail\")"

63 expectTutorialDErr sess conn (T.isPrefixOf "AtomTypeMismatchError") "execute multiArgFunc(\"fail\", \"fail\")"

57

64

58−

65+#endif