90e63c4 · project-m36 · git.iko.soy

Changelog.markdown+14

@@ -1,3 +1,17 @@

1+# 2018-06-04 (v0.4)

2+

3+* add contributed feature to allow users to [create arbitrary relations](https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown#arbitrary-relation-variables)

4+* fix type validation bug allowing concrete type with type variables in relations

5+* improve usability of `Interval a` data type

6+* allow `Integer` to be parsed as negative in `tutd` console

7+* support precompiled (Haskell) [`AtomFunction`s](https://github.com/agentm/project-m36/blob/master/docs/atomfunctions.markdown#pre-compiled-atom-functions) and [`DatabaseContextFunction`s](https://github.com/agentm/project-m36/blob/master/docs/database_context_functions.markdown#loading-precompiled-modules)

8+* make TutorialD scripts read from the filesystem unconditionally read as UTF-8

9+* improve support for display of multibyte characters in `tutd` console, especially Chinese

10+* fix file descriptor leak in file sychronization

11+* improve reliability by allowing fast-forward commits when using `autoMergeToHead`

12+* add [`semijoin` and `anitjoin`](https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown#join) support to `tutd`

13+* added various new static optimizations

14+

115# 2017-11-14

216

317* alter websocket server API to allow for multiple representations (JSON, text, or HTML) to be selected and returned simultaneously

README.markdown+1−1

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

8282### Integrations

8383

84841. [WebSocket Server](docs/websocket_server.markdown)

85−1. [Jupyter Notebook Kernel](docs/jupypter_kernel.markdown)

85+1. [Jupyter Notebook Kernel](docs/jupyter_kernel.markdown)

8686

8787## Development

8888

cbits/DirectoryFsync.c+3

@@ -24,11 +24,13 @@ int cDirectoryFsync(char *path)

2424 ret = fstat(fd,&fdstat);

2525 if(ret < 0)

2626 {

27+ close(fd);

2728 return errno;

2829 }

2930

3031 if(!S_ISDIR(fdstat.st_mode))

3132 {

33+ close(fd);

3234 return ENOTDIR;

3335 }

3436

@@ -39,6 +41,7 @@ int cDirectoryFsync(char *path)

3941#else

4042 ret = fsync(fd);

4143#endif

44+ close(fd);

4245 if(ret < 0)

4346 {

4447 return errno;

docs/atomfunctions.markdown+30−1

@@ -6,7 +6,7 @@ While Project:M36 includes a set of basic function which operate on relational v

66

77Other DBMSes also include this feature by way of stored functions such as with PL/pgsql, T-SQL, or PL/SQL.

88

9−Project:M36 allows users to implement strongly-typed and pure atom functions in the Haskell language at runtime. This facility makes use of GHC, the Haskell compiler, as a runtime service.

9+Project:M36 allows users to implement strongly-typed and pure atom functions in the Haskell language at runtime. This facility makes use of GHC, the Haskell compiler, as a runtime service. Alternatively, Haskell-based atom functions can be pre-compiled and loaded at runtime.

1010

1111## Atom Function Example

1212

@@ -41,6 +41,35 @@ Project:M36 also supports polymorphic types when used with atom functions. Here

4141addatomfunction "idTest" a -> Either AtomFunctionError a "(\(x:_) -> pure x) :: [Atom] -> Either AtomFunctionError Atom"

4242```

4343

44+## Pre-compiled Atom Functions

45+

46+Compiling atom functions at runtime can incur a performance cost. To mitigate this, atom functions can be compiled by GHC to object files and then loaded into the Project:M36 server. Let's look at an [example](https://github.com/agentm/project-m36/):

47+

48+```haskell

49+module DynamicAtomFunctions where

50+import ProjectM36.Base

51+

52+someAtomFunctions :: [AtomFunction]

53+someAtomFunctions = [AtomFunction{

54+ atomFuncName = "constTrue",

55+ atomFuncType = [TypeVariableType "a", BoolAtomType],

56+ atomFuncBody = AtomFunctionBody Nothing (\(x:_) -> pure (BoolAtom True))}]

57+```

58+

59+Any function inside any module which returns a list of `AtomFunction`s can be used to load more atom functions. First, create the Haskell object file:

60+

61+`cabal exec ghc -- examples/DynamicAtomFunctions.hs -package project-m36`

62+

63+Use cabal or stack to invoke ghc so that the project-m36 installed package will be found.

64+

65+Finally, connect to your Project:M36 database using the `tutd` client and run:

66+

67+`TutorialD (master/main): loadatomfunctions "DynamicAtomFunctions" "someFunctions" "examples/DynamicAtomFunctions.o"`

68+

69+If you see an error such as "unknown symbol", the version of the "project-m36" library installed in your sandbox is different from that with which you linked the object file. Make sure that the same versions are used in linking the server and object file.

70+

71+The atom function is now loaded and ready-to-use. Note, however, that the function must be added every time the project-m36-server starts. This will probably be improved in a future release.

72+

4473## Differences when compared to other DBMSes

4574

4675Project:M36 enforces strongly-typed atom functions. Specifically, atom functions must be pure (free of any side effects) and cannot operate on any variables other than the atoms passed in. This certainly sets stricter limits on what can be accomplished in an atom function when compared to stored functions in other DBMS products. For example, an atom function in Project:M36 would never be able to retrieve stock information from an external website because such a function cannot be pure and thus would be rejected by the atom function compiler. This restriction maintains the mathematical cohesiveness of the database and allows the DBMS to make performance-enhancing inferences it would not otherwise be able to make.

docs/database_context_functions.markdown+51−1

@@ -6,7 +6,7 @@ While "atom functions" operate on individual values and return new values (atoms

66

77Other DBMS software may include a similar feature called "stored procedures". However, "stored procedures" are stored outside the transaction stream and are not versioned by the database as in Project:M36.

88

9−In order to use this feature in Project:M36, be sure to build your own Project:M36 library so that the optional scripting is enabled.

9+In order to use compile functions at runtime in Project:M36, be sure to build your own Project:M36 library so that the optional scripting is enabled. Alternatively, precompiled database context functions can be loaded from object files.

1010

1111## Database Context Function Types

1212

@@ -112,6 +112,56 @@ executeDatabaseContextExpr sessionId dbconn (ExecuteDatabaseContextFunction func

112112```

113113from the same module.

114114

115+## Loading Precompiled Modules

116+

117+Database context functions compiled with GHC to object files can be loaded at runtime. Let's walk through an example:

118+

119+```haskell

120+module DynamicDatabaseContextFunctions where

121+import ProjectM36.Base

122+import ProjectM36.Relation

123+import ProjectM36.DatabaseContextFunctionError

124+import qualified ProjectM36.Attribute as A

125+

126+import qualified Data.Map as M

127+

128+

129+someDBCFunctions :: [DatabaseContextFunction]

130+someDBCFunctions = [DatabaseContextFunction {

131+ dbcFuncName = "addtestrel",

132+ dbcFuncType = [],

133+ dbcFuncBody = DatabaseContextFunctionBody Nothing addTestRel

134+ }]

135+ where

136+ addTestRel _ ctx = do

137+ let attrs = A.attributesFromList [Attribute "word" TextAtomType]

138+ eRel = mkRelationFromList attrs [[TextAtom "nice"]]

139+ case eRel of

140+ Left err -> Left (DatabaseContextFunctionUserError (show err))

141+ Right testRel ->

142+ pure $ ctx { relationVariables = M.insert "testRel" testRel (relationVariables ctx) }

143+```

144+

145+The function returns a list of `DatabaseContextFunction`s (just one in this case). The function adds a relation variable to the current database context.

146+

147+Compile it with GHC:

148+

149+```

150+cabal exec ghc -- examples/DynamicDatabaseContextFunctions.hs -package project-m36

151+```

152+

153+or invoked GHC via stack.

154+

155+Finally, connect to your database with `tutd` and load the module:

156+

157+```

158+TutorialD (master/main): loaddatabasecontextfunctions "DynamicDatabaseContextFunctions" "someDBCFunctions" "examples/DynamicDatabaseContextFunctions.o"

159+```

160+

161+If the load reports an "unknown symbol" error, double check that the installed "project-m36" package is identical to one used to link the Haskell module.

162+

163+Note that such functions do not survive a server restart; this will likely be improved in a future release.

164+

115165## Future Improvements

116166

117167There are likely a variety of convenience functions which would make sense in the context of the scripted function. If you have ideas for such functions, please open a GitHub issue.

docs/introduction_to_projectm36.markdown+2−2

@@ -1,7 +1,7 @@

11# Introduction to Project:M36

22

33## What is Project:M36?

4−Project:M36 is a relational-algebra-based database management system. It can be used a production-level database backend or for learning more about the relational algebra.

4+Project:M36 is a relational-algebra-based database management system. It can be used as a production-level database backend or for learning more about the relational algebra.

55

66The principled mathematical approach to Project:M36's design sets it apart from competing DBMSs. Specifically, Project:M36 adheres strongly to the mathematics of the relational algebra and makes no compromises nor apologies in doing so. To that end, Project:M36 is implemented in the programming language "Haskell" which is itself based on the lambda calculus.

77

@@ -65,7 +65,7 @@ In addition to being a relational algebra engine, Project:M36 supports features

6565

6666Most DBMSs provide a way to allow the user to specify atomic database state changes. These changes are often wrapped up as "transactions" which, when applied to the database state, offer the illusion of sequential and grouped, atomic changes applied to the databases. Often the only state which can be queried is the snapshot at the time the transaction is opened.

6767

68−Project:M36 extends this transaction model with the "transaction graph". This feture can be adequately described as version control for transactions. In the legacy DBMS model, the transactions are added to a linear transaction stream where each client is contending over the "head" of the stream- the latest transactions. In the transaction graph model, clients can add named branches and add transactions to the branches, then merge changes back, if necessary.

68+Project:M36 extends this transaction model with the "transaction graph". This feature can be adequately described as version control for transactions. In the legacy DBMS model, the transactions are added to a linear transaction stream where each client is contending over the "head" of the stream- the latest transactions. In the transaction graph model, clients can add named branches and add transactions to the branches, then merge changes back, if necessary.

6969

7070This feature is useful, for example:

7171* during testing- create a testing branch which production will never see. This obviates the need for a separate production data set.

docs/tutd_tutorial.markdown+196−168

@@ -20,14 +20,15 @@ TutorialD is strongly-typed. The basic built-in types are:

2020

2121|Type Name|Explanation|Example|

2222|---------|-----------|-------|

23−|text|arbitrary text|"The Old Man and the Sea"|

24−|int|any integer|-4|

25−|datetime|timestamp UTC|dateTimeFromEpochSeconds(1502304846)|

26−|date|calendar date|fromGregorian(2017,05,30)|

27−|double|floating point number|3.1459|

28−|bool|boolean value|t|

29−|bytestring|arbitrary-length string of bytes- input is base64-encoded|bytestring("dGVzdGRhdGE=")|

30−|interval x|interval/range type for ints, doubles, datetimes, and dates|interval(3,5,f,f)|

23+|Text|arbitrary text|"The Old Man and the Sea"|

24+|Integer|arbitarily-sized integer|-4|

25+|Int|machine word integer|int(10)|

26+|DateTime|timestamp UTC|dateTimeFromEpochSeconds(1502304846)|

27+|Date|calendar date|fromGregorian(2017,05,30)|

28+|Double|floating point number|3.1459|

29+|Bool|boolean value|t|

30+|Bytestring|arbitrary-length string of bytes- input is base64-encoded|bytestring("dGVzdGRhdGE=")|

31+|Interval x|interval/range type for ints, doubles, datetimes, and dates|interval(3,5,f,f)|

3132

3233With regards to boolean values, be sure not to conflate ```t``` or ```f``` as a boolean value with ```true``` and ```false``` which are relation variables.

3334

@@ -48,7 +49,7 @@ Relation Variables are named cells which reference relations within a transactio

4849

4950Definition of a relation variable:

5051```

51−products :: {name char, age int}

52+products :: {name Text, age Integer}

5253```

5354This expression creates a new relation variable in the current context which can refer to any relation with the header of "name" of type "char" and "age" of type int.

5455

@@ -151,15 +152,15 @@ The unary rename operator outputs a new relation with chosen attributes renamed.

151152

152153```

153154TutorialD (master/main): :showexpr s rename {city as town}

154−┌──┬─────┬──────┬──────┐

155−│s#│sname│status│town │

156−├──┼─────┼──────┼──────┤

157−│S3│Blake│30 │Paris │

158−│S4│Clark│20 │London│

159−│S5│Adams│30 │Athens│

160−│S1│Smith│20 │London│

161−│S2│Jones│10 │Paris │

162−└──┴─────┴──────┴──────┘

155+┌────────┬───────────┬───────────────┬──────────┐

156+│s#::Text│sname::Text│status::Integer│town::Text│

157+├────────┼───────────┼───────────────┼──────────┤

158+│"S3" │"Blake" │30 │"Paris" │

159+│"S4" │"Clark" │20 │"London" │

160+│"S5" │"Adams" │30 │"Athens" │

161+│"S1" │"Smith" │20 │"London" │

162+│"S2" │"Jones" │10 │"Paris" │

163+└────────┴───────────┴───────────────┴──────────┘

163164```

164165

165166#### Projection

@@ -170,14 +171,15 @@ For example:

170171

171172```

172173TutorialD (master/main): :showexpr p{color,city}

173−┌──────┬─────┐

174−│city │color│

175−├──────┼─────┤

176−│London│Red │

177−│Paris │Blue │

178−│Oslo │Blue │

179−│Paris │Green│

180−└──────┴─────┘

174+┌──────────┬───────────┐

175+│city::Text│color::Text│

176+├──────────┼───────────┤

177+│"London" │"Red" │

178+│"Paris" │"Green" │

179+│"Oslo" │"Blue" │

180+│"Paris" │"Blue" │

181+└──────────┴───────────┘

182+

181183```

182184

183185Projection attributes can also be inverted using `all but`:

@@ -217,22 +219,22 @@ Restriction is applied using a "where" clause, much like in SQL.

217219

218220```

219221TutorialD (master/main): :showexpr p where color="Blue" and city="Paris"

220−┌─────┬─────┬──┬─────┬──────┐

221−│city │color│p#│pname│weight│

222−├─────┼─────┼──┼─────┼──────┤

223−│Paris│Blue │P5│Cam │12 │

224−└─────┴─────┴──┴─────┴──────┘

222+┌──────────┬───────────┬────────┬───────────┬───────────────┐

223+│city::Text│color::Text│p#::Text│pname::Text│weight::Integer│

224+├──────────┼───────────┼────────┼───────────┼───────────────┤

225+│"Paris" │"Blue" │"P5" │"Cam" │12 │

226+└──────────┴───────────┴────────┴───────────┴───────────────┘

225227```

226228

227229The restriction predicate can be built from "and", "not", and "or". Boolean atom functions can also appear in a restriction as long as they are preceded by "^". For example:

228230

229231```

230232TutorialD (master/main): :showexpr s where ^lt(@status,20)

231−┌─────┬──┬─────┬──────┐

232−│city │s#│sname│status│

233−├─────┼──┼─────┼──────┤

234−│Paris│S2│Jones│10 │

235−└─────┴──┴─────┴──────┘

233+┌──────────┬────────┬───────────┬───────────────┐

234+│city::Text│s#::Text│sname::Text│status::Integer│

235+├──────────┼────────┼───────────┼───────────────┤

236+│"Paris" │"S2" │"Jones" │10 │

237+└──────────┴────────┴───────────┴───────────────┘

236238```

237239

238240#### Join

@@ -241,21 +243,22 @@ Joins are binary operators and are applied with the "join" keyword. The equivale

241243

242244```

243245TutorialD (master/main): :showexpr s join sp

244−┌──────┬──┬───┬──┬─────┬──────┐

245−│city │p#│QTY│s#│sname│status│

246−├──────┼──┼───┼──┼─────┼──────┤

247−│London│P6│100│S1│Smith│20 │

248−│London│P3│400│S1│Smith│20 │

249−│London│P5│400│S4│Clark│20 │

250−│London│P1│300│S1│Smith│20 │

251−│Paris │P2│200│S3│Blake│30 │

252−│Paris │P1│300│S2│Jones│10 │

253−│London│P5│100│S1│Smith│20 │

254−│London│P4│300│S4│Clark│20 │

255−│Paris │P2│400│S2│Jones│10 │

256−│London│P2│200│S1│Smith│20 │

257−│London│P4│200│S1│Smith│20 │

258−└──────┴──┴───┴──┴─────┴──────┘

246+┌──────────┬────────┬────────────┬────────┬───────────┬───────────────┐

247+│city::Text│p#::Text│qty::Integer│s#::Text│sname::Text│status::Integer│

248+├──────────┼────────┼────────────┼────────┼───────────┼───────────────┤

249+│"London" │"P2" │200 │"S1" │"Smith" │20 │

250+│"London" │"P6" │100 │"S1" │"Smith" │20 │

251+│"London" │"P3" │400 │"S1" │"Smith" │20 │

252+│"Paris" │"P2" │400 │"S2" │"Jones" │10 │

253+│"London" │"P5" │400 │"S4" │"Clark" │20 │

254+│"Paris" │"P1" │300 │"S2" │"Jones" │10 │

255+│"London" │"P1" │300 │"S1" │"Smith" │20 │

256+│"Paris" │"P2" │200 │"S3" │"Blake" │30 │

257+│"London" │"P4" │300 │"S4" │"Clark" │20 │

258+│"London" │"P2" │200 │"S4" │"Clark" │20 │

259+│"London" │"P4" │200 │"S1" │"Smith" │20 │

260+│"London" │"P5" │100 │"S1" │"Smith" │20 │

261+└──────────┴────────┴────────────┴────────┴───────────┴───────────────┘

259262```

260263

261264As a convenience, `tutd` also supports semijoin (`matching`) and antijoin (`not matching`) syntax.

@@ -269,16 +272,16 @@ As a convenience, `tutd` also supports semijoin (`matching`) and antijoin (`not

269272The binary union operator merges tuples from both relations if-and-only-if the attributes of both relations are identical. The SQL equivalent is the "UNION" operator. Unlike SQL, however, duplicate tuples are not tolerated, so there is no "UNION ALL" equivalent in the relational algebra.

270273

271274```

272−TutorialD (master/main): :showexpr S union S

273−┌──────┬──┬─────┬──────┐

274−│city │s#│sname│status│

275−├──────┼──┼─────┼──────┤

276−│Paris │S3│Blake│30 │

277−│London│S4│Clark│20 │

278−│Athens│S5│Adams│30 │

279−│London│S1│Smith│20 │

280−│Paris │S2│Jones│10 │

281−└──────┴──┴─────┴──────┘

275+TutorialD (master/main): :showexpr s union s

276+┌──────────┬────────┬───────────┬───────────────┐

277+│city::Text│s#::Text│sname::Text│status::Integer│

278+├──────────┼────────┼───────────┼───────────────┤

279+│"Paris" │"S3" │"Blake" │30 │

280+│"Athens" │"S5" │"Adams" │30 │

281+│"London" │"S1" │"Smith" │20 │

282+│"Paris" │"S2" │"Jones" │10 │

283+│"London" │"S4" │"Clark" │20 │

284+└──────────┴────────┴───────────┴───────────────┘

282285```

283286

284287The union of any relation with itself is itself.

@@ -289,15 +292,15 @@ The extend unary operator adds an attribute to a relation's header and body and

289292

290293```

291294TutorialD (master/main): :showexpr s:{status2:=add(10,@status)}

292−┌──────┬──┬─────┬──────┬───────┐

293−│city │s#│sname│status│status2│

294−├──────┼──┼─────┼──────┼───────┤

295−│Paris │S2│Jones│10 │20 │

296−│Athens│S5│Adams│30 │40 │

297−│Paris │S3│Blake│30 │40 │

298−│London│S1│Smith│20 │30 │

299−│London│S4│Clark│20 │30 │

300−└──────┴──┴─────┴──────┴───────┘

295+┌──────────┬────────┬───────────┬───────────────┬────────────────┐

296+│city::Text│s#::Text│sname::Text│status::Integer│status2::Integer│

297+├──────────┼────────┼───────────┼───────────────┼────────────────┤

298+│"Paris" │"S2" │"Jones" │10 │20 │

299+│"Athens" │"S5" │"Adams" │30 │40 │

300+│"London" │"S4" │"Clark" │20 │30 │

301+│"Paris" │"S3" │"Blake" │30 │40 │

302+│"London" │"S1" │"Smith" │20 │30 │

303+└──────────┴────────┴───────────┴───────────────┴────────────────┘

301304```

302305

303306The "@" is required in the above query in order to distinguish the attribute's name from a relation's name.

@@ -323,27 +326,27 @@ The group operator can also be used to emulate functionality similar to SQL's OU

323326

324327```

325328TutorialD (master/main): :showexpr s group ({sname,status,s#} as subrel)

326−┌──────┬─────────────────┐

327−│city │subrel │

328−├──────┼─────────────────┤

329−│Athens│┌──┬─────┬──────┐│

330−│ ││s#│sname│status││

331−│ │├──┼─────┼──────┤│

332−│ ││S5│Adams│30 ││

333−│ │└──┴─────┴──────┘│

334−│London│┌──┬─────┬──────┐│

335−│ ││s#│sname│status││

336−│ │├──┼─────┼──────┤│

337−│ ││S1│Smith│20 ││

338−│ ││S4│Clark│20 ││

339−│ │└──┴─────┴──────┘│

340−│Paris │┌──┬─────┬──────┐│

341−│ ││s#│sname│status││

342−│ │├──┼─────┼──────┤│

343−│ ││S3│Blake│30 ││

344−│ ││S2│Jones│10 ││

345−│ │└──┴─────┴──────┘│

346−└──────┴─────────────────┘

329+┌──────────┬───────────────────────────────────────────────────────┐

330+│city::Text│subrel::relation {s#::Text,sname::Text,status::Integer}│

331+├──────────┼───────────────────────────────────────────────────────┤

332+│"Athens" │┌────────┬───────────┬───────────────┐ │

333+│ ││s#::Text│sname::Text│status::Integer│ │

334+│ │├────────┼───────────┼───────────────┤ │

335+│ ││"S5" │"Adams" │30 │ │

336+│ │└────────┴───────────┴───────────────┘ │

337+│"Paris" │┌────────┬───────────┬───────────────┐ │

338+│ ││s#::Text│sname::Text│status::Integer│ │

339+│ │├────────┼───────────┼───────────────┤ │

340+│ ││"S2" │"Jones" │10 │ │

341+│ ││"S3" │"Blake" │30 │ │

342+│ │└────────┴───────────┴───────────────┘ │

343+│"London" │┌────────┬───────────┬───────────────┐ │

344+│ ││s#::Text│sname::Text│status::Integer│ │

345+│ │├────────┼───────────┼───────────────┤ │

346+│ ││"S4" │"Clark" │20 │ │

347+│ ││"S1" │"Smith" │20 │ │

348+│ │└────────┴───────────┴───────────────┘ │

349+└──────────┴───────────────────────────────────────────────────────┘

347350```

348351

349352#### Ungroup

@@ -352,15 +355,15 @@ The unary ungroup operator "unwraps" subrelations in a relation-valued attribute

352355

353356```

354357TutorialD (master/main): :showexpr (s group ({sname,status,s#} as subrel)) ungroup subrel

355−┌──────┬──┬─────┬──────┐

356−│city │s#│sname│status│

357−├──────┼──┼─────┼──────┤

358−│Paris │S3│Blake│30 │

359−│London│S4│Clark│20 │

360−│Athens│S5│Adams│30 │

361−│London│S1│Smith│20 │

362−│Paris │S2│Jones│10 │

363−└──────┴──┴─────┴──────┘

358+┌──────────┬────────┬───────────┬───────────────┐

359+│city::Text│s#::Text│sname::Text│status::Integer│

360+├──────────┼────────┼───────────┼───────────────┤

361+│"Paris" │"S2" │"Jones" │10 │

362+│"Paris" │"S3" │"Blake" │30 │

363+│"London" │"S4" │"Clark" │20 │

364+│"London" │"S1" │"Smith" │20 │

365+│"Athens" │"S5" │"Adams" │30 │

366+└──────────┴────────┴───────────┴───────────────┘

364367```

365368

366369#### Minus

@@ -393,11 +396,11 @@ The relation variable assignment mentioned above certainly changes the state of

393396```

394397TutorialD (master/main): newrelvar:=relation{tuple{age 3}}

395398TutorialD (master/main): :showexpr newrelvar

396−┌───┐

397−│age│

398−├───┤

399−│3 │

400−└───┘

399+┌────────────┐

400+│age::Integer│

401+├────────────┤

402+│3 │

403+└────────────┘

401404```

402405

403406All further operators are convenience operators and could be implemented with simple assignment. SQL has no equivalent to relational assignment; instead, one must issue "CREATE TABLE" commands and insert rows into the resultant tables.

@@ -419,16 +422,16 @@ The insert operators accepts a relation variable and a relation of the same type

419422```

420423TutorialD (master/main): insert s relation{tuple{city "Boston",s# "S10",sname "Gonzalez",status 10}}

421424TutorialD (master/main): :showexpr s

422−┌──────┬───┬────────┬──────┐

423−│city │s# │sname │status│

424−├──────┼───┼────────┼──────┤

425−│Paris │S3 │Blake │30 │

426−│London│S4 │Clark │20 │

427−│Athens│S5 │Adams │30 │

428−│London│S1 │Smith │20 │

429−│Paris │S2 │Jones │10 │

430−│Boston│S10│Gonzalez│10 │

431−└──────┴───┴────────┴──────┘

425+┌──────────┬────────┬───────────┬───────────────┐

426+│city::Text│s#::Text│sname::Text│status::Integer│

427+├──────────┼────────┼───────────┼───────────────┤

428+│"Athens" │"S5" │"Adams" │30 │

429+│"Paris" │"S2" │"Jones" │10 │

430+│"Boston" │"S10" │"Gonzalez" │10 │

431+│"London" │"S4" │"Clark" │20 │

432+│"London" │"S1" │"Smith" │20 │

433+│"Paris" │"S3" │"Blake" │30 │

434+└──────────┴────────┴───────────┴───────────────┘

432435```

433436

434437This insertion operation is equivalent to:

@@ -443,15 +446,15 @@ The update operator accepts a relation argument and a predicate, optionally filt

443446```

444447TutorialD (master/main): update s where status=20 (sname:="Mr. Twenty")

445448TutorialD (master/main): :showexpr s

446−┌──────┬──┬──────────┬──────┐

447−│city │s#│sname │status│

448−├──────┼──┼──────────┼──────┤

449−│Paris │S3│Blake │30 │

450−│London│S1│Mr. Twenty│20 │

451−│Athens│S5│Adams │30 │

452−│Paris │S2│Jones │10 │

453−│London│S4│Mr. Twenty│20 │

454−└──────┴──┴──────────┴──────┘

449+┌──────────┬────────┬────────────┬───────────────┐

450+│city::Text│s#::Text│sname::Text │status::Integer│

451+├──────────┼────────┼────────────┼───────────────┤

452+│"Paris" │"S2" │"Jones" │10 │

453+│"London" │"S1" │"Mr. Twenty"│20 │

454+│"Paris" │"S3" │"Blake" │30 │

455+│"London" │"S4" │"Mr. Twenty"│20 │

456+│"Athens" │"S5" │"Adams" │30 │

457+└──────────┴────────┴────────────┴───────────────┘

455458```

456459

457460This is logically equivalent to:

@@ -459,15 +462,15 @@ This is logically equivalent to:

459462```

460463TutorialD (master/main): s:=(((s where status=20){city,s#,status}):{sname:="Mr. Twenty"}) union (s where not status=20)

461464TutorialD (master/main): :showexpr s

462−┌──────┬──┬──────────┬──────┐

463−│city │s#│sname │status│

464−├──────┼──┼──────────┼──────┤

465−│Paris │S3│Blake │30 │

466−│London│S1│Mr. Twenty│20 │

467−│Athens│S5│Adams │30 │

468−│Paris │S2│Jones │10 │

469−│London│S4│Mr. Twenty│20 │

470−└──────┴──┴──────────┴──────┘

465+┌──────────┬────────┬────────────┬───────────────┐

466+│city::Text│s#::Text│sname::Text │status::Integer│

467+├──────────┼────────┼────────────┼───────────────┤

468+│"Paris" │"S2" │"Jones" │10 │

469+│"London" │"S1" │"Mr. Twenty"│20 │

470+│"Paris" │"S3" │"Blake" │30 │

471+│"London" │"S4" │"Mr. Twenty"│20 │

472+│"Athens" │"S5" │"Adams" │30 │

473+└──────────┴────────┴────────────┴───────────────┘

471474```

472475

473476This query means: "Drop the sname attribute from S filtered where status equals 20, extend the resultant relation by sname with value 'Mr. Twenty', then union the resultant relation with S filtered by status not equaling 20, and assign that to S."

@@ -479,19 +482,19 @@ The delete operator accepts a relation argument and a filtering predicate, creat

479482```

480483TutorialD (master/main): delete sp where s#="S4"

481484TutorialD (master/main): :showexpr sp

482−┌──┬───┬──┐

483−│p#│QTY│s#│

484−├──┼───┼──┤

485−│P3│400│S1│

486−│P4│200│S1│

487−│P2│400│S2│

488−│P2│200│S1│

489−│P6│100│S1│

490−│P1│300│S1│

491−│P2│200│S3│

492−│P1│300│S2│

493−│P5│100│S1│

494−└──┴───┴──┘

485+┌────────┬────────────┬────────┐

486+│p#::Text│qty::Integer│s#::Text│

487+├────────┼────────────┼────────┤

488+│"P2" │200 │"S3" │

489+│"P2" │400 │"S2" │

490+│"P1" │300 │"S1" │

491+│"P5" │100 │"S1" │

492+│"P4" │200 │"S1" │

493+│"P1" │300 │"S2" │

494+│"P3" │400 │"S1" │

495+│"P2" │200 │"S1" │

496+│"P6" │100 │"S1" │

497+└────────┴────────────┴────────┘

495498```

496499

497500This is logically equivalent to:

@@ -526,7 +529,7 @@ Foreign keys are constraints which require that certain values appearing in one

526529TutorialD (master/main): foreign key s#_in_sp sp{s#} in s{s#}

527530```

528531

529−This expression ensure that any sp{s#} must also appear as a value in s{s#}. Note that the sub-expression (on the left of "in") and the super-expression (on the right) must be of the same relation type- the generated relation values' attribute names and types must be equal. Use `rename` to make attribute names identical.

532+This expression ensure that any sp{s#} must also appear as a value in s{s#}. Note that the sub-expression (on the left of "in") and the super-expression (on the right) must be of the same relation type- the generated relation values' attribute names and types must be equal. Use `rename` to make attribute names identical.

530533

531534#### Functional dependencies

532535

@@ -560,27 +563,27 @@ SQL supports aggregate queries using aggregate functions (SUM(), COUNT(), AVERAG

560563

561564```

562565TutorialD (master/main): :showexpr s group ({s#,sname,status} as subrel):{citycount:=count(@subrel)}

563−┌──────┬─────────┬─────────────────┐

564−│city │citycount│subrel │

565−├──────┼─────────┼─────────────────┤

566−│Paris │2 │┌──┬─────┬──────┐│

567−│ │ ││s#│sname│status││

568−│ │ │├──┼─────┼──────┤│

569−│ │ ││S3│Blake│30 ││

570−│ │ ││S2│Jones│10 ││

571−│ │ │└──┴─────┴──────┘│

572−│London│2 │┌──┬─────┬──────┐│

573−│ │ ││s#│sname│status││

574−│ │ │├──┼─────┼──────┤│

575−│ │ ││S1│Smith│20 ││

576−│ │ ││S4│Clark│20 ││

577−│ │ │└──┴─────┴──────┘│

578−│Athens│1 │┌──┬─────┬──────┐│

579−│ │ ││s#│sname│status││

580−│ │ │├──┼─────┼──────┤│

581−│ │ ││S5│Adams│30 ││

582−│ │ │└──┴─────┴──────┘│

583−└──────┴─────────┴─────────────────┘

566+┌──────────┬──────────────────┬───────────────────────────────────────────────────────┐

567+│city::Text│citycount::Integer│subrel::relation {s#::Text,sname::Text,status::Integer}│

568+├──────────┼──────────────────┼───────────────────────────────────────────────────────┤

569+│"Athens" │1 │┌────────┬───────────┬───────────────┐ │

570+│ │ ││s#::Text│sname::Text│status::Integer│ │

571+│ │ │├────────┼───────────┼───────────────┤ │

572+│ │ ││"S5" │"Adams" │30 │ │

573+│ │ │└────────┴───────────┴───────────────┘ │

574+│"Paris" │2 │┌────────┬───────────┬───────────────┐ │

575+│ │ ││s#::Text│sname::Text│status::Integer│ │

576+│ │ │├────────┼───────────┼───────────────┤ │

577+│ │ ││"S2" │"Jones" │10 │ │

578+│ │ ││"S3" │"Blake" │30 │ │

579+│ │ │└────────┴───────────┴───────────────┘ │

580+│"London" │2 │┌────────┬───────────┬───────────────┐ │

581+│ │ ││s#::Text│sname::Text│status::Integer│ │

582+│ │ │├────────┼───────────┼───────────────┤ │

583+│ │ ││"S4" │"Clark" │20 │ │

584+│ │ ││"S1" │"Smith" │20 │ │

585+│ │ │└────────┴───────────┴───────────────┘ │

586+└──────────┴──────────────────┴───────────────────────────────────────────────────────┘

584587```

585588

586589In this query result, we can simultaneously answer how many suppliers are located in each city and which suppliers they are. The expression is constructed by first grouping to isolate the city, then extending the query to add a attribute containing the tuple count for each subrelation.

@@ -591,3 +594,28 @@ In this query result, we can simultaneously answer how many suppliers are locate

591594|sum(relation{int})|return the int sum of the relation's values|

592595|max(relation{int})|return the maximum int from all the relation's values|

593596|min(relation{int})|return the minimum int from all the relation's values|

597+

598+#### Arbitrary Relation Variables

599+

600+For testing purposes, it can be useful to populate a database with randomly generated data. Project:M36 can automatically create such data based solely on the type of the relation.

601+

602+```

603+TutorialD (master/main): createarbitraryrelation employee {name Text, empid Int, hired DateTime} 3-100

604+TutorialD (master/main): :showexpr employee

605+┌──────────┬───────────────────────┬──────────┐

606+│empid::Int│hired::DateTime │name::Text│

607+├──────────┼───────────────────────┼──────────┤

608+│23 │1858-11-04 10:50:14 UTC│"LLL" │

609+│22 │1858-12-10 14:53:37 UTC│"LLL" │

610+│25 │1858-11-07 01:14:15 UTC│"SSS" │

611+│-12 │1858-11-06 06:20:57 UTC│"VVV" │

612+│-6 │1858-11-01 16:26:38 UTC│"SSS" │

613+│-1 │1858-10-31 14:41:26 UTC│"DDD" │

614+│-15 │1858-11-26 04:14:03 UTC│"VVV" │

615+│-18 │1858-12-17 00:01:09 UTC│"AAA" │

616+│-9 │1858-10-31 08:36:53 UTC│"XXX" │

617+│4 │1858-11-23 01:48:04 UTC│"VVV" │

618+└──────────┴───────────────────────┴──────────┘

619+```

620+

621+The `createarbitraryrelation` syntax specifies the name of the relation variable, the type for the relation, and then an acceptable range for the tuple count.

docs/websocket_server.markdown+1−1

@@ -6,7 +6,7 @@ The Project:M36 WebSocket server makes it easy to connect non-Haskell programs t

66

77## Setup

88

9−The websocket server is started with the same arguments as the normal [Project:M36 server](docs/server_mode.markdown):

9+The websocket server is started with the same arguments as the normal [Project:M36 server](server_mode.markdown):

1010

1111```

1212cabal run project-m36-websocket-server -- --database mydbname --hostname 127.0.0.1

examples/CustomTupleable.hsnew file+67

@@ -0,0 +1,67 @@

1+{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}

2+--this example shows how to implement a non-generics-defined Tupleable instance which is required in scenarios where Haskell-side types are not supported server-side or where one wishes to represent a nested relation

3+import ProjectM36.Client

4+import ProjectM36.Tuple

5+import ProjectM36.Tupleable

6+import ProjectM36.Relation

7+import ProjectM36.Atom

8+import ProjectM36.Attribute as A

9+import qualified Data.Set as S

10+import qualified Data.Map as M

11+import Data.Text (Text)

12+import GHC.Generics

13+import Data.Proxy

14+

15+--in this contrived example, we wish to represent one relation with a nested relation of comments

16+data Blog = Blog {

17+ title :: Text,

18+ comments :: S.Set Comment

19+ } deriving (Show)

20+

21+data Comment = Comment {

22+ authorName :: Text,

23+ comment :: Text

24+ } deriving (Eq, Show, Generic, Ord)

25+

26+instance Tupleable Comment

27+

28+instance Tupleable Blog where

29+ toTuple blogentry =

30+ mkRelationTupleFromMap (M.fromList [("title", TextAtom (title blogentry)),

31+ ("comments", RelationAtom relFromComments)])

32+ where

33+ commentTuples = map toTuple (S.toList (comments blogentry))

34+ relFromComments = case mkRelationFromTuples (toAttributes (Proxy :: Proxy Comment)) commentTuples of

35+ Left err -> error (show err)

36+ Right rel -> rel

37+

38+ fromTuple tupIn = do

39+ titleAtom <- atomForAttributeName "title" tupIn

40+ commentsAtom <- atomForAttributeName "comments" tupIn

41+ commentsRel <- relationForAtom commentsAtom

42+ comments' <- mapM fromTuple (tuplesList commentsRel)

43+ pure Blog {

44+ title = atomToText titleAtom,

45+ comments = S.fromList comments'}

46+

47+ toAttributes _ = A.attributesFromList [Attribute "title" TextAtomType,

48+ Attribute "comments" $ RelationAtomType (toAttributes (Proxy :: Proxy Comment))]

49+

50+main :: IO ()

51+main = do

52+ let exampleBlog = Blog { title = "Cat Pics",

53+ comments = S.fromList [Comment {authorName = "Steve",

54+ comment = "great"},

55+ Comment {authorName = "Bob",

56+ comment = "enough"}

57+ ]}

58+ print (toTuple exampleBlog)

59+ print (fromTuple (toTuple exampleBlog) :: Either RelationalError Blog)

60+

61+

62+

63+

64+

65+

66+

67+

examples/DynamicAtomFunctions.hsnew file+12

@@ -0,0 +1,12 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+--compile with `cabal exec ghc -- examples/DynamicAtomFunctions.hs -package project-m36`

3+--load with `loadatomfunctions "DynamicAtomFunctions" "someAtomFunctions" "examples/DynamicAtomFunctions.o"`

4+

5+module DynamicAtomFunctions where

6+import ProjectM36.Base

7+

8+someAtomFunctions :: [AtomFunction]

9+someAtomFunctions = [AtomFunction{

10+ atomFuncName = "constTrue",

11+ atomFuncType = [TypeVariableType "a", BoolAtomType],

12+ atomFuncBody = AtomFunctionBody Nothing (\(x:_) -> pure (BoolAtom True))}]

examples/DynamicDatabaseContextFunctions.hsnew file+26

@@ -0,0 +1,26 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+--compile with `cabal exec ghc -- examples/DynamicDatabaseContextFunctions.hs -package project-m36`

3+--load with `loaddatabasecontextfunctions "DynamicDatabaseContextFunctions" "someDBCFunctions" "examples/DynamicDatabaseContextFunctions.o"`

4+module DynamicDatabaseContextFunctions where

5+import ProjectM36.Base

6+import ProjectM36.Relation

7+import ProjectM36.DatabaseContextFunctionError

8+import qualified ProjectM36.Attribute as A

9+

10+import qualified Data.Map as M

11+

12+

13+someDBCFunctions :: [DatabaseContextFunction]

14+someDBCFunctions = [DatabaseContextFunction {

15+ dbcFuncName = "addtestrel",

16+ dbcFuncType = [],

17+ dbcFuncBody = DatabaseContextFunctionBody Nothing addTestRel

18+ }]

19+ where

20+ addTestRel _ ctx = do

21+ let attrs = A.attributesFromList [Attribute "word" TextAtomType]

22+ eRel = mkRelationFromList attrs [[TextAtom "nice"]]

23+ case eRel of

24+ Left err -> Left (DatabaseContextFunctionUserError (show err))

25+ Right testRel ->

26+ pure $ ctx { relationVariables = M.insert "testRel" testRel (relationVariables ctx) }

examples/SimpleClient.hs+2−1

@@ -1,6 +1,7 @@

11import ProjectM36.Client

22import ProjectM36.TupleSet

33import ProjectM36.Relation.Show.Term

4+import Data.Text.IO as TIO

45

56main :: IO ()

67main = do

@@ -32,7 +33,7 @@ main = do

3233 eRel <- executeRelationalExpr sessionId conn (Restrict restrictionPredicate (RelationVariable "person" ()))

3334 case eRel of

3435 Left err -> print err

35− Right rel -> print (showRelation rel)

36+ Right rel -> TIO.putStrLn (showRelation rel)

3637

3738 --7. close the connection

3839 close conn

project-m36.cabal+25−7

@@ -44,6 +44,7 @@ Library

4444 ,vector

4545 ,parallel

4646 ,monad-parallel

47+ ,exceptions

4748 ,transformers

4849 ,gnuplot

4950 ,binary

@@ -56,6 +57,7 @@ Library

5657 ,time

5758 ,hashable-time

5859 ,old-locale

60+ ,rset

5961 --used for CSV parsing

6062 ,attoparsec

6163 ,either

@@ -69,6 +71,9 @@ Library

6971 ,conduit

7072 ,resourcet

7173 ,http-api-data

74+ ,semigroups

75+ -- used for arbitrary tuples

76+ ,QuickCheck

7277--needed for remote access

7378 ,distributed-process-client-server >= 0.2.3

7479 ,distributed-process >= 0.7.2

@@ -78,6 +83,8 @@ Library

7883 ,network-transport

7984 ,list-t

8085 ,stm-containers >= 0.2.15

86+ ,foldl

87+ ,deferred-folds

8188 ,optparse-applicative

8289 ,Glob

8390--used for hashing the transaction graph file to check for differences

@@ -111,6 +118,7 @@ Library

111118 ProjectM36.Relation.Show.HTML,

112119 ProjectM36.StaticOptimizer,

113120 ProjectM36.Relation.Show.Term,

121+ ProjectM36.WCWidth,

114122 ProjectM36.Relation.Show.CSV,

115123 ProjectM36.Relation.Show.Gnuplot,

116124 ProjectM36.Relation.Parse.CSV,

@@ -120,6 +128,7 @@ Library

120128 ProjectM36.Client.Simple,

121129 ProjectM36.Persist,

122130 ProjectM36.AtomType,

131+ ProjectM36.AttributeExpr,

123132 ProjectM36.AtomFunctions.Basic,

124133 ProjectM36.AtomFunctions.Primitive,

125134 ProjectM36.Atomable,

@@ -131,6 +140,7 @@ Library

131140 ProjectM36.DataTypes.Either,

132141 ProjectM36.DataTypes.Maybe,

133142 ProjectM36.DataTypes.List,

143+ ProjectM36.DataTypes.NonEmptyList,

134144 ProjectM36.DataTypes.Primitive,

135145 ProjectM36.DataTypes.Interval,

136146 ProjectM36.DataTypes.ByteString,

@@ -148,21 +158,22 @@ Library

148158 ProjectM36.TypeConstructor,

149159 ProjectM36.TypeConstructorDef,

150160 ProjectM36.FileLock,

151− ProjectM36.FSType

152− GHC-Options: -Wall

161+ ProjectM36.FSType,

162+ ProjectM36.Arbitrary

163+ GHC-Options: -Wall -rdynamic

153164 if os(windows)

154165 Build-Depends: Win32 >= 2.3

155166 Other-Modules: ProjectM36.Win32Handle

156167 else

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

158169 Build-Depends: unix

159− CC-Options: -fPIC

170+ CC-Options: -fPIC

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

161172 Default-Language: Haskell2010

162173 Default-Extensions: OverloadedStrings, CPP

163174 if impl(ghc>= 8)

164175 build-depends:

165− ghc-boot

176+ ghc-boot, ghci

166177

167178Executable tutd

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

@@ -200,7 +211,7 @@ Executable tutd

200211 base64-bytestring,

201212 optparse-applicative,

202213 attoparsec,

203− stm-containers,

214+ stm-containers >= 1.0.0,

204215 list-t

205216 Other-Modules: TutorialD.Interpreter,

206217 TutorialD.Interpreter.Base,

@@ -222,7 +233,7 @@ Executable tutd

222233 TutorialD.Interpreter.SchemaOperator

223234 main-is: TutorialD/tutd.hs

224235 CC-Options: -fPIC

225− GHC-Options: -Wall

236+ GHC-Options: -Wall -rdynamic

226237 Hs-Source-Dirs: ./src/bin

227238 Default-Language: Haskell2010

228239 Default-Extensions: OverloadedStrings

@@ -427,6 +438,13 @@ Executable Example-Hair

427438 Main-Is: examples/hair.hs

428439 GHC-Options: -Wall

429440

441+Executable Example-CustomTupleable

442+ Default-Language: Haskell2010

443+ Default-Extensions: OverloadedStrings

444+ 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, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36

445+ Main-Is: examples/CustomTupleable.hs

446+ GHC-Options: -Wall

447+

430448Test-Suite test-scripts

431449 Default-Language: Haskell2010

432450 Default-Extensions: OverloadedStrings

@@ -540,4 +558,4 @@ Executable handles

540558 if flag(profiler)

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

542560

543−

561+

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs+1−18

@@ -80,15 +80,6 @@ instance ToJSON Atom where

8080 "val" .= decodeUtf8 (B64.encode i) ]

8181 toJSON atom@(BoolAtom i) = object [ "type" .= atomTypeForAtom atom,

8282 "val" .= i ]

83−

84− toJSON atom@(IntervalAtom b e i1 i2) = object [ "type" .= atomTypeForAtom atom,

85− "val" .= object [

86− "begin" .= toJSON b,

87− "end" .= toJSON e,

88− "beginopen" .= i1,

89− "endopen" .= i2

90− ]

91− ]

9283 toJSON atom@(RelationAtom i) = object [ "type" .= atomTypeForAtom atom,

9384 "val" .= i ]

9485 toJSON (ConstructedAtom dConsName atomtype atomlist) = object [

@@ -103,9 +94,7 @@ instance FromJSON Atom where

10394 case atype of

10495 TypeVariableType _ -> fail "cannot pass TypeVariableType over the wire"

10596 caType@(ConstructedAtomType _ _) -> ConstructedAtom <$> o .: "dataconstructorname" <*> pure caType <*> o .: "atom"

106− RelationAtomType _ -> do

107− rel <- o .: "val"

108− pure $ RelationAtom rel

97+ RelationAtomType _ -> RelationAtom <$> o .: "val"

10998 IntAtomType -> IntAtom <$> o .: "val"

11099 IntegerAtomType -> IntegerAtom <$> o .: "val"

111100 DoubleAtomType -> DoubleAtom <$> o .: "val"

@@ -120,12 +109,6 @@ instance FromJSON Atom where

120109 Left err -> fail ("Failed to parse base64-encoded ByteString: " ++ err)

121110 Right bs -> pure (ByteStringAtom bs)

122111 BoolAtomType -> BoolAtom <$> o .: "val"

123− IntervalAtomType _ -> IntervalAtom <$>

124− ((o .: "val") >>= (.: "begin")) <*>

125− ((o .: "val") >>= (.: "end")) <*>

126− ((o .: "val") >>= (.: "beginopen")) <*>

127− ((o .: "val") >>= (.: "endopen"))

128−

129112

130113instance ToJSON Notification

131114instance FromJSON Notification

src/bin/ProjectM36/Server/WebSocket/websocket-server.hs+7

@@ -1,10 +1,17 @@

1+{-# LANGUAGE CPP #-}

12import ProjectM36.Server.WebSocket

23import ProjectM36.Server.Config

34import ProjectM36.Server.ParseArgs

45import ProjectM36.Server

56import Control.Concurrent

67import qualified Network.WebSockets as WS

8+

9+#if MIN_VERSION_network_transport_tcp(0,6,0)

710import Network.Transport.TCP.Internal (decodeEndPointAddress)

11+#else

12+import Network.Transport.TCP (decodeEndPointAddress)

13+#endif

14+

815import Control.Exception

916

1017main :: IO ()

src/bin/TutorialD/Interpreter/Base.hs+3−8

@@ -19,7 +19,7 @@ import Text.Megaparsec.Char

1919import qualified Text.Megaparsec.Char.Lexer as Lex

2020import Text.Megaparsec

2121import Data.Void

22−import Control.Applicative

22+import Control.Applicative hiding (many, some)

2323#else

2424import Text.Megaparsec.Text

2525import qualified Text.Megaparsec.Lexer as Lex

@@ -117,16 +117,11 @@ arrow = symbol "->"

117117semi :: Parser Text

118118semi = symbol ";"

119119

120−{-

121−whiteSpace :: Parser ()

122−whiteSpace = Token.whiteSpace lexer

123−-}

124−

125120integer :: Parser Integer

126121#if MIN_VERSION_megaparsec(6,0,0)

127−integer = Lex.decimal

122+integer = Lex.signed spaceConsumer Lex.decimal

128123#else

129−integer = Lex.integer

124+integer = Lex.signed spaceConsumer Lex.integer

130125#endif

131126

132127float :: Parser Double

src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+8−15

@@ -45,23 +45,20 @@ assignP = do

4545 relVarName <- identifier

4646 reservedOp ":="

4747 return relVarName

48− expr <- relExprP

49− pure $ Assign relVarName expr

48+ Assign relVarName <$> relExprP

5049

5150multilineSep :: Parser T.Text

5251multilineSep = newline >> pure "\n"

5352

5453multipleDatabaseContextExprP :: Parser DatabaseContextExpr

55−multipleDatabaseContextExprP = do

56− exprs <- sepBy1 databaseContextExprP semi

57− pure $ MultipleExpr exprs

54+multipleDatabaseContextExprP =

55+ MultipleExpr <$> sepBy1 databaseContextExprP semi

5856

5957insertP :: Parser DatabaseContextExpr

6058insertP = do

6159 reservedOp "insert"

6260 relvar <- identifier

63− expr <- relExprP

64− pure $ Insert relvar expr

61+ Insert relvar <$> relExprP

6562

6663defineP :: Parser DatabaseContextExpr

6764defineP = do

@@ -69,8 +66,7 @@ defineP = do

6966 relVarName <- identifier

7067 reservedOp "::"

7168 return relVarName

72− attributeSet <- makeAttributeExprsP

73− pure $ Define relVarName attributeSet

69+ Define relVarName <$> makeAttributeExprsP

7470

7571undefineP :: Parser DatabaseContextExpr

7672undefineP = do

@@ -109,8 +105,7 @@ addConstraintP = do

109105deleteConstraintP :: Parser DatabaseContextExpr

110106deleteConstraintP = do

111107 reserved "deleteconstraint"

112− constraintName <- identifier

113− pure $ RemoveInclusionDependency constraintName

108+ RemoveInclusionDependency <$> identifier

114109

115110-- key <constraint name> {<uniqueness attributes>} <uniqueness relexpr>

116111keyP :: Parser DatabaseContextExpr

@@ -150,14 +145,12 @@ addNotificationP = do

150145 notName <- identifier

151146 triggerExpr <- relExprP

152147 resultOldExpr <- relExprP

153− resultNewExpr <- relExprP

154− pure $ AddNotification notName triggerExpr resultOldExpr resultNewExpr

148+ AddNotification notName triggerExpr resultOldExpr <$> relExprP

155149

156150removeNotificationP :: Parser DatabaseContextExpr

157151removeNotificationP = do

158152 reserved "unnotify"

159− notName <- identifier

160− pure $ RemoveNotification notName

153+ RemoveNotification <$> identifier

161154

162155-- | data Hair = Bald | Color Text

163156addTypeConstructorP :: Parser DatabaseContextExpr

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

@@ -10,19 +10,41 @@ addAtomFunctionExprP = dbioexprP "addatomfunction" AddAtomFunction

1010

1111addDatabaseContextFunctionExprP :: Parser DatabaseContextIOExpr

1212addDatabaseContextFunctionExprP = dbioexprP "adddatabasecontextfunction" AddDatabaseContextFunction

13+

14+createArbitraryRelationP :: Parser DatabaseContextIOExpr

15+createArbitraryRelationP = do

16+ reserved "createarbitraryrelation"

17+ relVarName <- identifier

18+ attrExprs <- makeAttributeExprsP :: Parser [AttributeExpr]

19+ min' <- fromInteger <$> integer

20+ _ <- symbol "-"

21+ max' <- fromInteger <$> integer

22+ pure $ CreateArbitraryRelation relVarName attrExprs (min',max')

1323

1424dbioexprP :: ParseStr -> (Text -> [TypeConstructor] -> Text -> DatabaseContextIOExpr) -> Parser DatabaseContextIOExpr

1525dbioexprP res adt = do

1626 reserved res

1727 funcName <- quotedString

1828 funcType <- atomTypeSignatureP

19− funcScript <- quotedString

20− pure $ adt funcName funcType funcScript

29+ adt funcName funcType <$> quotedString

2130

2231atomTypeSignatureP :: Parser [TypeConstructor]

2332atomTypeSignatureP = sepBy typeConstructorP arrow

2433

2534dbContextIOExprP :: Parser DatabaseContextIOExpr

26−dbContextIOExprP = addAtomFunctionExprP <|> addDatabaseContextFunctionExprP

27−

35+dbContextIOExprP = addAtomFunctionExprP <|>

36+ addDatabaseContextFunctionExprP <|>

37+ loadAtomFunctionsP <|>

38+ loadDatabaseContextFunctionsP <|>

39+ createArbitraryRelationP

40+

41+loadAtomFunctionsP :: Parser DatabaseContextIOExpr

42+loadAtomFunctionsP = do

43+ reserved "loadatomfunctions"

44+ LoadAtomFunctions <$> quotedString <*> quotedString <*> fmap unpack quotedString

45+

46+loadDatabaseContextFunctionsP :: Parser DatabaseContextIOExpr

47+loadDatabaseContextFunctionsP = do

48+ reserved "loaddatabasecontextfunctions"

49+ LoadDatabaseContextFunctions <$> quotedString <*> quotedString <*> fmap unpack quotedString

2850

src/bin/TutorialD/Interpreter/Import/TutorialD.hs+13−9

@@ -7,20 +7,24 @@ import ProjectM36.Error

77import qualified ProjectM36.Error as PM36E

88import qualified Data.Text as T

99import Control.Exception

10−import qualified Data.Text.IO as TIO

10+import qualified Data.ByteString as BS

11+import qualified Data.Text.Encoding as TE

1112--import a file containing TutorialD database context expressions

1213

1314importTutorialD :: FilePath -> IO (Either RelationalError DatabaseContextExpr)

1415importTutorialD pathIn = do

15− tutdData <- try (TIO.readFile pathIn) :: IO (Either IOError T.Text)

16− case tutdData of

16+ eTutdBytes <- try (BS.readFile pathIn) :: IO (Either IOError BS.ByteString)

17+ case eTutdBytes of

1718 Left err -> return $ Left (ImportError $ T.pack (show err))

18− Right tutdData' ->

19− case parse multipleDatabaseContextExprP "import" tutdData' of

20− --parseErrorPretty is new in megaparsec 5

21− Left err -> pure (Left (PM36E.ParseError (T.pack (show err))))

22− Right expr -> pure (Right expr)

23−

19+ Right tutdBytes ->

20+ case TE.decodeUtf8' tutdBytes of

21+ Left err -> pure (Left (ImportError $ T.pack (show err)))

22+ Right tutdUtf8 ->

23+ case parse multipleDatabaseContextExprP "import" tutdUtf8 of

24+ --parseErrorPretty is new in megaparsec 5

25+ Left err -> pure (Left (PM36E.ParseError (T.pack (show err))))

26+ Right expr -> pure (Right expr)

27+

2428tutdImportP :: Parser DatabaseContextDataImportOperator

2529tutdImportP = do

2630 reserved ":importtutd"

src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs+22

@@ -22,6 +22,8 @@ data RODatabaseContextOperator where

2222 ShowPlan :: DatabaseContextExpr -> RODatabaseContextOperator

2323 ShowTypes :: RODatabaseContextOperator

2424 ShowRelationVariables :: RODatabaseContextOperator

25+ ShowAtomFunctions :: RODatabaseContextOperator

26+ ShowDatabaseContextFunctions :: RODatabaseContextOperator

2527 Quit :: RODatabaseContextOperator

2628 deriving (Show)

2729

@@ -46,6 +48,12 @@ showTypesP = reserved ":showtypes" >> pure ShowTypes

4648showRelationVariables :: Parser RODatabaseContextOperator

4749showRelationVariables = reserved ":showrelvars" >> pure ShowRelationVariables

4850

51+showAtomFunctionsP :: Parser RODatabaseContextOperator

52+showAtomFunctionsP = reserved ":showatomfunctions" >> pure ShowAtomFunctions

53+

54+showDatabaseContextFunctionsP :: Parser RODatabaseContextOperator

55+showDatabaseContextFunctionsP = reserved ":showdatabasecontextfunctions" >> pure ShowDatabaseContextFunctions

56+

4957quitP :: Parser RODatabaseContextOperator

5058quitP = do

5159 reservedOp ":quit"

@@ -69,6 +77,8 @@ roDatabaseContextOperatorP = typeP

6977 <|> showConstraintsP

7078 <|> showPlanP

7179 <|> showTypesP

80+ <|> showAtomFunctionsP

81+ <|> showDatabaseContextFunctionsP

7282 <|> quitP

7383

7484--logically, these read-only operations could happen purely, but not if a remote call is required

@@ -123,6 +133,18 @@ evalRODatabaseContextOp sessionId conn ShowRelationVariables = do

123133 case eRel of

124134 Left err -> pure $ DisplayErrorResult (T.pack (show err))

125135 Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))

136+

137+evalRODatabaseContextOp sessionId conn ShowAtomFunctions = do

138+ eRel <- C.atomFunctionsAsRelation sessionId conn

139+ case eRel of

140+ Left err -> pure $ DisplayErrorResult (T.pack (show err))

141+ Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))

142+

143+evalRODatabaseContextOp sessionId conn ShowDatabaseContextFunctions = do

144+ eRel <- C.databaseContextFunctionsAsRelation sessionId conn

145+ case eRel of

146+ Left err -> pure $ DisplayErrorResult (T.pack (show err))

147+ Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))

126148

127149evalRODatabaseContextOp _ _ Quit = pure QuitResult

128150

src/bin/TutorialD/Interpreter/RelationalExpr.hs+18−20

@@ -10,12 +10,6 @@ import qualified Data.Map as M

1010import Data.List (sort)

1111import ProjectM36.MiscUtils

1212

13−class RelationalMarkerExpr a where

14− parseMarkerP :: Parser a

15−

16−instance RelationalMarkerExpr () where

17− parseMarkerP = pure ()

18−

1913--used in projection

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

2115attributeListP =

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

3226 tupleExprs <- braces (sepBy tupleExprP comma) <|> pure []

3327 pure $ MakeRelationFromExprs attrExprs tupleExprs

3428

35−--used in relation creation

36−makeAttributeExprsP :: RelationalMarkerExpr a => Parser [AttributeExprBase a]

37−makeAttributeExprsP = braces (sepBy attributeAndTypeNameP comma)

38−

39−attributeAndTypeNameP :: RelationalMarkerExpr a => Parser (AttributeExprBase a)

40−attributeAndTypeNameP = AttributeAndTypeNameExpr <$> identifier <*> typeConstructorP <*> parseMarkerP

4129

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

4331--Either Text Int

@@ -65,9 +53,7 @@ tupleAtomExprP = do

6553 pure (attributeName, atomExpr)

6654

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

68−projectP = do

69− attrs <- braces attributeListP

70− pure $ Project attrs

56+projectP = Project <$> braces attributeListP

7157

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

7359renameClauseP = do

@@ -105,8 +91,7 @@ groupP = do

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

10692ungroupP = do

10793 reservedOp "ungroup"

108− rvaAttrName <- identifier

109− pure $ Ungroup rvaAttrName

94+ Ungroup <$> identifier

11095

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

11297extendP = do

@@ -143,7 +128,7 @@ relOperators = [

143128 ]

144129

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

146−relExprP = makeExprParser relTerm relOperators

131+relExprP = try withMacroExprP <|> makeExprParser relTerm relOperators

147132

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

149134relVarP = RelationVariable <$> identifier <*> parseMarkerP

@@ -217,8 +202,7 @@ constructedAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a

217202constructedAtomExprP consume = do

218203 dConsName <- capitalizedIdentifier

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

220− marker <- parseMarkerP

221− pure $ ConstructedAtomExpr dConsName dConsArgs marker

205+ ConstructedAtomExpr dConsName dConsArgs <$> parseMarkerP

222206

223207-- used only for primitive type parsing ?

224208atomP :: Parser Atom

@@ -250,3 +234,17 @@ boolAtomP = do

250234

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

252236relationAtomExprP = RelationAtomExpr <$> makeRelationP

237+

238+withMacroExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)

239+withMacroExprP = do

240+ reservedOp "with"

241+ views <- parens (sepBy1 createViewP comma)

242+ With views <$> relExprP

243+

244+createViewP :: RelationalMarkerExpr a => Parser (RelVarName, RelationalExprBase a)

245+createViewP = do

246+ name <- identifier

247+ reservedOp "as"

248+ expr <- relExprP

249+ pure (name, expr)

250+

src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs+3−4

@@ -3,6 +3,7 @@

33module TutorialD.Interpreter.TransGraphRelationalOperator where

44import ProjectM36.TransGraphRelationalExpression

55import ProjectM36.TransactionGraph

6+import TutorialD.Interpreter.Types

67import qualified ProjectM36.Client as C

78

89import TutorialD.Interpreter.Base

@@ -12,7 +13,7 @@ import qualified Data.Text as T

1213

1314instance RelationalMarkerExpr TransactionIdLookup where

1415 parseMarkerP = string "@" *> transactionIdLookupP

15−

16+

1617newtype TransGraphRelationalOperator = ShowTransGraphRelation TransGraphRelationalExpr

1718 deriving Show

1819

@@ -26,9 +27,7 @@ transactionIdHeadBacktrackP = (string "~" *> (TransactionIdHeadParentBacktrack <

2627 (string "@" *> (TransactionStampHeadBacktrack <$> utcTimeP))

2728

2829backtrackP :: Parser Int

29−backtrackP = do

30− steps <- integer <|> pure 1

31− pure (fromIntegral steps)

30+backtrackP = fromIntegral <$> integer <|> pure 1

3231

3332transGraphRelationalOpP :: Parser TransGraphRelationalOperator

3433transGraphRelationalOpP = showTransGraphRelationalOpP

src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs+3−8

@@ -61,20 +61,15 @@ mergeTransactionStrategyP :: Parser MergeStrategy

6161mergeTransactionStrategyP = (reserved "union" $> UnionMergeStrategy) <|>

6262 (do

6363 reserved "selectedbranch"

64− branch <- identifier

65− pure (SelectedBranchMergeStrategy branch)) <|>

64+ SelectedBranchMergeStrategy <$> identifier) <|>

6665 (do

6766 reserved "unionpreferbranch"

68− branch <- identifier

69− pure (UnionPreferMergeStrategy branch))

67+ UnionPreferMergeStrategy <$> identifier)

7068

7169mergeTransactionsP :: Parser TransactionGraphOperator

7270mergeTransactionsP = do

7371 reservedOp ":mergetrans"

74− strategy <- mergeTransactionStrategyP

75− headA <- identifier

76− headB <- identifier

77− pure (MergeTransactions strategy headA headB)

72+ MergeTransactions <$> mergeTransactionStrategyP <*> identifier <*> identifier

7873

7974transactionGraphOpP :: Parser TransactionGraphOperator

8075transactionGraphOpP =

src/bin/TutorialD/Interpreter/Types.hs+21−12

@@ -3,8 +3,13 @@ module TutorialD.Interpreter.Types where

33import ProjectM36.Base

44import Text.Megaparsec

55import TutorialD.Interpreter.Base

6−import ProjectM36.DataTypes.Primitive

76

7+class RelationalMarkerExpr a where

8+ parseMarkerP :: Parser a

9+

10+instance RelationalMarkerExpr () where

11+ parseMarkerP = pure ()

12+

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

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

1015typeConstructorDefP :: Parser TypeConstructorDef

@@ -23,25 +28,29 @@ dataConstructorDefArgP = parens (DataConstructorDefTypeConstructorArg <$> typeCo

2328 DataConstructorDefTypeConstructorArg <$> typeConstructorP <|>

2429 DataConstructorDefTypeVarNameArg <$> uncapitalizedIdentifier

2530

26−--built-in, nullary type constructors

27−-- Int, Text, etc.

28−primitiveTypeConstructorP :: Parser TypeConstructor

29−primitiveTypeConstructorP = choice (map (\(PrimitiveTypeConstructorDef name typ, _) -> do

30− tName <- try $ symbol name

31− pure $ PrimitiveTypeConstructor tName typ)

32− primitiveTypeConstructorMapping)

31+-- relation{a Int} in type construction (no tuples parsed)

32+relationTypeConstructorP :: Parser TypeConstructor

33+relationTypeConstructorP = do

34+ reserved "relation"

35+ RelationAtomTypeConstructor <$> makeAttributeExprsP

36+

37+--used in relation creation

38+makeAttributeExprsP :: RelationalMarkerExpr a => Parser [AttributeExprBase a]

39+makeAttributeExprsP = braces (sepBy attributeAndTypeNameP comma)

40+

41+attributeAndTypeNameP :: RelationalMarkerExpr a => Parser (AttributeExprBase a)

42+attributeAndTypeNameP = AttributeAndTypeNameExpr <$> identifier <*> typeConstructorP <*> parseMarkerP

3343

3444-- *Either Int Text*, *Int*

3545typeConstructorP :: Parser TypeConstructor

36−typeConstructorP = primitiveTypeConstructorP <|>

46+typeConstructorP = relationTypeConstructorP <|>

3747 TypeVariable <$> uncapitalizedIdentifier <|>

3848 ADTypeConstructor <$> capitalizedIdentifier <*> many (parens typeConstructorP <|>

3949 monoTypeConstructorP)

4050

4151monoTypeConstructorP :: Parser TypeConstructor

42−monoTypeConstructorP = primitiveTypeConstructorP <|>

43− ADTypeConstructor <$> capitalizedIdentifier <*> pure [] <|>

44− TypeVariable <$> uncapitalizedIdentifier

52+monoTypeConstructorP = ADTypeConstructor <$> capitalizedIdentifier <*> pure [] <|>

53+ TypeVariable <$> uncapitalizedIdentifier

4554

4655

4756

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

@@ -6,14 +6,14 @@ import ProjectM36.DateExamples

66import ProjectM36.Error

77import qualified ProjectM36.Attribute as A

88import qualified Data.Text as T

9−import ProjectM36.Relation.Show.CSV

9+--import ProjectM36.Relation.Show.CSV

1010import ProjectM36.Relation.Show.HTML

1111import TutorialD.Interpreter.DatabaseContextExpr (interpretDatabaseContextExpr)

1212import ProjectM36.RelationalExpression

13−import qualified Data.HashSet as HS

14−import qualified Data.ByteString.Lazy.Char8 as BS

15−import qualified Data.IntMap as IM

16−import qualified Data.Hashable as Hash

13+--import qualified Data.HashSet as HS

14+--import qualified Data.ByteString.Lazy.Char8 as BS

15+--import qualified Data.IntMap as IM

16+--import qualified Data.Hashable as Hash

1717import qualified Data.Vector as V

1818import Options.Applicative

1919import qualified Data.Map as M

@@ -30,6 +30,7 @@ dumpcsv rel = case relationAsCSV rel of

3030 Left err -> hPrint stderr err

3131 Right bsData -> BS.putStrLn bsData

3232-}

33+

3334data BigrelArgs = BigrelArgs Int Int Text

3435

3536parseAttributeCount :: Parser Int

@@ -74,6 +75,7 @@ intmapMatrixRun = do

7475 let matrix = intmapMatrixRelation 100 100000

7576 print matrix

7677-}

78+

7779--compare IntMap speed and size

7880--this is about 3 times faster (9 minutes) for 10x100000 and uses 800 MB

7981{-

@@ -82,8 +84,9 @@ intmapMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tu

8284 where

8385 mapper tupCount = IM.fromList $ map (\c-> (c, IntAtom (fromIntegral tupCount))) [0..attributeCount]

8486-}

85−instance Hash.Hashable (IM.IntMap Atom) where

86− hashWithSalt salt tupMap = Hash.hashWithSalt salt (show tupMap)

87+-- instance Hash.Hashable (IM.IntMap Atom) where

88+-- hashWithSalt salt tupMap = Hash.hashWithSalt salt (show tupMap)

89+

8790{-

8891vectorMatrixRun :: IO ()

8992vectorMatrixRun = do

@@ -93,6 +96,12 @@ vectorMatrixRun = do

9396-- 20 s 90 MBs- a clear win- ideal size is 10 * 100000 * 8 bytes = 80 MB! without IntAtom wrapper

9497--with IntAtom wrapper: 1m12s 90 MB

9598{-

99+

100+

101+-- 20 s 90 MBs- a clear win- ideal size is 10 * 100000 * 8 bytes = 80 MB! without IntAtom wrapper

102+--with IntAtom wrapper: 1m12s 90 MB

103+{-

104+

96105vectorMatrixRelation :: Int -> Int -> HS.HashSet (V.Vector Atom)

97106vectorMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tupleCount]

98107 where

@@ -100,7 +109,7 @@ vectorMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tu

100109-}

101110instance Hash.Hashable (V.Vector Atom) where

102111 hashWithSalt salt vec = Hash.hashWithSalt salt (show vec)

103−

112+-}

104113-- returns a relation with tupleCount tuples with a set of integer attributes attributesCount long

105114-- this is useful for performance and resource usage testing

106115matrixRelation :: Int -> Int -> Either RelationalError Relation

src/lib/ProjectM36/Arbitrary.hsnew file+133

@@ -0,0 +1,133 @@

1+{-# LANGUAGE ExistentialQuantification,FlexibleInstances,OverloadedStrings #-}

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

3+

4+module ProjectM36.Arbitrary where

5+import ProjectM36.Base

6+import ProjectM36.Error

7+import ProjectM36.AtomFunctionError

8+import ProjectM36.AtomType

9+import ProjectM36.Attribute (atomType)

10+import ProjectM36.DataConstructorDef as DCD

11+import ProjectM36.DataTypes.Interval

12+import qualified Data.Vector as V

13+import Data.Text (Text,pack)

14+import Test.QuickCheck

15+import qualified Data.ByteString.Char8 as B

16+import Data.Time

17+import Control.Monad.Reader

18+

19+arbitrary' :: AtomType -> WithTCMap Gen (Either RelationalError Atom)

20+arbitrary' IntegerAtomType =

21+ Right . IntegerAtom <$> lift (arbitrary :: Gen Integer)

22+

23+arbitrary' (RelationAtomType attrs) = do

24+ tcMap <-ask

25+ maybeRel <- lift $ runReaderT (arbitraryRelation attrs (0,5)) tcMap

26+ case maybeRel of

27+ Left err -> pure $ Left err

28+ Right rel -> pure $ Right $ RelationAtom rel

29+

30+arbitrary' IntAtomType =

31+ Right . IntAtom <$> lift (arbitrary :: Gen Int)

32+

33+arbitrary' DoubleAtomType =

34+ Right . DoubleAtom <$> lift (arbitrary :: Gen Double)

35+

36+arbitrary' TextAtomType =

37+ Right . TextAtom <$> lift (arbitrary :: Gen Text)

38+

39+arbitrary' DayAtomType =

40+ Right . DayAtom <$> lift (arbitrary :: Gen Day)

41+

42+arbitrary' DateTimeAtomType =

43+ Right . DateTimeAtom <$> lift (arbitrary :: Gen UTCTime)

44+

45+arbitrary' ByteStringAtomType =

46+ Right . ByteStringAtom <$> lift (arbitrary :: Gen B.ByteString)

47+

48+arbitrary' BoolAtomType =

49+ Right . BoolAtom <$> lift (arbitrary :: Gen Bool)

50+arbitrary' constructedAtomType@(ConstructedAtomType tcName tvMap)

51+ --special-casing for Interval type

52+ | isIntervalAtomType constructedAtomType = createArbitraryInterval (intervalSubType constructedAtomType)

53+ | otherwise = do

54+ tcMap <- ask

55+ let maybeTCons = findTypeConstructor tcName tcMap

56+ let eitherTCons = maybeToRight (NoSuchTypeConstructorName tcName) maybeTCons

57+ let eitherDCDefs = snd <$> eitherTCons

58+ let eitherGenDCDef = elements <$> eitherDCDefs

59+ case eitherGenDCDef of

60+ Left err -> pure $ Left err

61+ Right genDCDef -> do

62+ dcDef <- lift genDCDef

63+ case resolvedAtomTypesForDataConstructorDefArgs tcMap tvMap dcDef of

64+ Left err -> pure $ Left err

65+ Right atomTypes -> do

66+ let genListOfEitherAtom = mapM (\aTy->runReaderT (arbitrary' aTy) tcMap) atomTypes

67+ listOfEitherAtom <- lift genListOfEitherAtom

68+ let eitherListOfAtom = sequence listOfEitherAtom

69+ case eitherListOfAtom of

70+ Left err -> pure $ Left err

71+ Right listOfAtom -> pure $ Right $ ConstructedAtom (DCD.name dcDef) constructedAtomType listOfAtom

72+arbitrary' (TypeVariableType _) = error "arbitrary on type variable"

73+

74+maybeToRight :: b -> Maybe a -> Either b a

75+maybeToRight _ (Just x) = Right x

76+maybeToRight y Nothing = Left y

77+

78+instance Arbitrary Text where

79+ arbitrary = pack <$> elements (map (replicate 3) ['A'..'Z'])

80+

81+instance Arbitrary Day where

82+ arbitrary = ModifiedJulianDay <$> (arbitrary :: Gen Integer)

83+

84+instance Arbitrary UTCTime where

85+ arbitrary = UTCTime <$> arbitrary <*> (secondsToDiffTime <$> choose(0,86400))

86+

87+instance Arbitrary B.ByteString where

88+ arbitrary = B.pack <$> (arbitrary :: Gen String)

89+

90+arbitraryRelationTuple :: Attributes -> WithTCMap Gen (Either RelationalError RelationTuple)

91+arbitraryRelationTuple attris = do

92+ tcMap <- ask

93+ listOfMaybeAType <- lift $ mapM ((\aTy -> runReaderT (arbitrary' aTy) tcMap) . atomType) (V.toList attris)

94+ case sequence listOfMaybeAType of

95+ Left err -> pure $ Left err

96+ Right listOfAttr -> do

97+ let vectorOfAttr = V.fromList listOfAttr

98+ pure $ Right $ RelationTuple attris vectorOfAttr

99+

100+arbitraryWithRange :: Gen (Either RelationalError RelationTuple) -> Range -> Gen [Either RelationalError RelationTuple]

101+arbitraryWithRange genEitherTuple range = do

102+ num <- choose range

103+ vectorOf num genEitherTuple

104+

105+arbitraryRelation :: Attributes -> Range -> WithTCMap Gen (Either RelationalError Relation)

106+arbitraryRelation attris range = do

107+ tcMap <- ask

108+ let genEitherTuple = runReaderT (arbitraryRelationTuple attris) tcMap

109+ listOfEitherTuple <- lift $ arbitraryWithRange genEitherTuple range

110+ let eitherTupleList = sequence listOfEitherTuple

111+ case eitherTupleList of

112+ Left err -> pure $ Left err

113+ Right tupleList -> pure $ Right $ Relation attris $ RelationTupleSet tupleList

114+

115+type WithTCMap a = ReaderT TypeConstructorMapping a

116+

117+createArbitraryInterval :: AtomType -> WithTCMap Gen (Either RelationalError Atom)

118+createArbitraryInterval subType = if supportsInterval subType then do

119+ eBegin <- arbitrary' subType

120+ eEnd <- arbitrary' subType

121+ beginopen <- lift (arbitrary :: Gen Bool)

122+ endopen <- lift (arbitrary :: Gen Bool)

123+ case eBegin of

124+ Left err -> pure (Left err)

125+ Right begin ->

126+ case eEnd of

127+ Left err -> pure (Left err)

128+ Right end ->

129+ case createInterval begin end beginopen endopen of

130+ Left _ -> createArbitraryInterval subType

131+ Right val -> pure (Right val)

132+ else

133+ pure $ Left (ProjectM36.Error.AtomFunctionUserError (AtomTypeDoesNotSupportIntervalError (prettyAtomType subType)))

src/lib/ProjectM36/Atom.hs+12−10

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

11module ProjectM36.Atom where

22import ProjectM36.Base

33import ProjectM36.Error

4+import ProjectM36.DataTypes.Interval

45import qualified Data.Text as T

5−--import Data.Time.Calendar

6−--import Data.Time.Clock

7−--import Data.ByteString (ByteString)

86import Data.Monoid

97

108relationForAtom :: Atom -> Either RelationalError Relation

@@ -15,19 +13,23 @@ atomToText :: Atom -> T.Text

1513atomToText (IntegerAtom i) = (T.pack . show) i

1614atomToText (IntAtom i) = (T.pack . show) i

1715atomToText (DoubleAtom i) = (T.pack . show) i

18−atomToText (TextAtom i) = (T.pack . show) i --does this break quoting in CSV export?

16+atomToText (TextAtom i) = (T.pack . show) i --quotes necessary for ConstructedAtom subatoms

1917atomToText (DayAtom i) = (T.pack . show) i

2018atomToText (DateTimeAtom i) = (T.pack . show) i

2119atomToText (ByteStringAtom i) = (T.pack . show) i

2220atomToText (BoolAtom i) = (T.pack . show) i

23−atomToText (IntervalAtom b e bo be) = beginp <> begin <> "," <> end <> endp

24− where beginp = if bo then "(" else "["

25− begin = atomToText b

26− end = atomToText e

27− endp = if be then ")" else "]"

2821

2922atomToText (RelationAtom i) = (T.pack . show) i

30−atomToText (ConstructedAtom dConsName _ atoms) = dConsName <> dConsArgs

23+atomToText (ConstructedAtom dConsName typ atoms)

24+ | isIntervalAtomType typ = case atoms of --special handling for printing intervals

25+ [b, e, BoolAtom bo, BoolAtom be] ->

26+ let beginp = if bo then "(" else "["

27+ begin = atomToText b

28+ end = atomToText e

29+ endp = if be then ")" else "]" in

30+ beginp <> begin <> "," <> end <> endp

31+ _ -> "invalid interval"

32+ | otherwise = dConsName <> dConsArgs

3133 where

3234 parensAtomToText a@(ConstructedAtom _ _ []) = atomToText a

3335 parensAtomToText a@ConstructedAtom{} = "(" <> atomToText a <> ")"

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

@@ -1,11 +1,17 @@

11module ProjectM36.AtomFunction where

22import ProjectM36.Base

33import ProjectM36.Error

4+import ProjectM36.Relation

5+import ProjectM36.AtomType

46import ProjectM36.AtomFunctionError

7+import ProjectM36.ScriptSession

58import qualified ProjectM36.Attribute as A

69import qualified Data.HashSet as HS

10+import qualified Data.Text as T

11+

712

813foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

14+--the underscore in the attribute name means that any attributes are acceptable

915foldAtomFuncType foldType returnType = [RelationAtomType (A.attributesFromList [Attribute "_" foldType]), returnType]

1016

1117atomFunctionForName :: AtomFunctionName -> AtomFunctions -> Either RelationalError AtomFunction

@@ -64,4 +70,15 @@ createScriptedAtomFunction funcName argsType retType = AddAtomFunction funcName

6470 argsType ++ [ADTypeConstructor "Either" [

6571 ADTypeConstructor "AtomFunctionError" [],

6672 retType]])

67−

73+

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

75+loadAtomFunctions = loadFunction

76+

77+atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation

78+atomFunctionsAsRelation funcs = mkRelationFromList attrs tups

79+ where tups = map atomFuncToTuple (HS.toList funcs)

80+ attrs = A.attributesFromList [Attribute "name" TextAtomType,

81+ Attribute "arguments" TextAtomType]

82+ atomFuncToTuple aFunc = [TextAtom (atomFuncName aFunc),

83+ TextAtom (atomFuncTypeToText aFunc)]

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

src/lib/ProjectM36/AtomFunctionError.hs+1

@@ -9,6 +9,7 @@ data AtomFunctionError = AtomFunctionUserError String |

99 AtomFunctionTypeMismatchError |

1010 InvalidIntervalOrderingError |

1111 InvalidIntervalBoundariesError |

12+ InvalidIntBoundError |

1213 AtomFunctionEmptyRelationError |

1314 AtomTypeDoesNotSupportOrderingError Text |

1415 AtomTypeDoesNotSupportIntervalError Text |

src/lib/ProjectM36/AtomFunctions/Basic.hs+2

@@ -6,6 +6,7 @@ import ProjectM36.DataTypes.Either

66import ProjectM36.DataTypes.Maybe

77import ProjectM36.DataTypes.Interval

88import ProjectM36.DataTypes.ByteString

9+import ProjectM36.DataTypes.NonEmptyList

910import ProjectM36.AtomFunctions.Primitive

1011import ProjectM36.AtomFunction

1112import ProjectM36.DataTypes.List

@@ -19,6 +20,7 @@ basicAtomFunctions = HS.unions [primitiveAtomFunctions,

1920 eitherAtomFunctions,

2021 maybeAtomFunctions,

2122 listAtomFunctions,

23+ nonEmptyListAtomFunctions,

2224 bytestringAtomFunctions,

2325 intervalAtomFunctions]

2426

src/lib/ProjectM36/AtomFunctions/Primitive.hs+9−1

@@ -43,7 +43,15 @@ primitiveAtomFunctions = HS.fromList [

4343 atomFuncBody = body $ integerAtomFuncLessThan True >=> boolAtomNot},

4444 AtomFunction { atomFuncName = "not",

4545 atomFuncType = [BoolAtomType, BoolAtomType],

46− atomFuncBody = body $ \(b:_) -> boolAtomNot b }

46+ atomFuncBody = body $ \(b:_) -> boolAtomNot b },

47+ AtomFunction { atomFuncName = "int",

48+ atomFuncType = [IntegerAtomType, IntAtomType],

49+ atomFuncBody = body $ \(IntegerAtom v:_) -> if v < fromIntegral (maxBound :: Int) then

50+ pure (IntAtom (fromIntegral v))

51+ else

52+ Left InvalidIntBoundError

53+ }

54+

4755 ]

4856 where

4957 body = AtomFunctionBody Nothing

src/lib/ProjectM36/AtomType.hs+129−55

@@ -6,6 +6,7 @@ import qualified ProjectM36.DataConstructorDef as DCD

66import ProjectM36.MiscUtils

77import ProjectM36.Error

88import ProjectM36.DataTypes.Primitive

9+import ProjectM36.AttributeExpr as AE

910import qualified ProjectM36.Attribute as A

1011import qualified Data.Vector as V

1112import qualified Data.Set as S

@@ -30,6 +31,7 @@ findDataConstructor dName = foldr tConsFolder Nothing

3031 [dCons] -> Just dCons

3132 _ -> error "More than one data constructor with the same name found"

3233

34+{-

3335-- | Scan the atom types and return the resultant ConstructedAtomType or error.

3436-- Used in typeFromAtomExpr to validate argument types.

3537atomTypeForDataConstructorName :: DataConstructorName -> [AtomType] -> TypeConstructorMapping -> Either RelationalError AtomType

@@ -38,28 +40,21 @@ atomTypeForDataConstructorName dConsName atomTypesIn tConsList =

3840 case findDataConstructor dConsName tConsList of

3941 Nothing -> Left (NoSuchDataConstructorError dConsName)

4042 Just (tCons, dCons) -> do

41− typeVars <- resolveDataConstructorTypeVars dCons atomTypesIn tConsList

42− pure (ConstructedAtomType (TCD.name tCons) typeVars)

43+ dConsVars <- resolveDataConstructorTypeVars dCons atomTypesIn tConsList

44+ let tConsVars = M.fromList (map TypeVariableType (TCD.typeVars tCons))

45+ allVars = M.union dConsVars tConsVars

46+ ConstructedAtomType (TCD.name tCons) <$> allVars

47+-}

4348

4449atomTypeForDataConstructorDefArg :: DataConstructorDefArg -> AtomType -> TypeConstructorMapping -> Either RelationalError AtomType

45−atomTypeForDataConstructorDefArg (DataConstructorDefTypeConstructorArg tCons) aType tConss =

46− case isValidAtomTypeForTypeConstructor aType tCons tConss of

47− Just err -> Left err

48− Nothing -> Right aType

50+atomTypeForDataConstructorDefArg (DataConstructorDefTypeConstructorArg tCons) aType tConss = do

51+ isValidAtomTypeForTypeConstructor aType tCons tConss

52+ pure aType

4953

5054atomTypeForDataConstructorDefArg (DataConstructorDefTypeVarNameArg _) aType _ = Right aType --any type is OK

5155

52−--reconcile the atom-in types with the type constructors

53−isValidAtomTypeForTypeConstructor :: AtomType -> TypeConstructor -> TypeConstructorMapping -> Maybe RelationalError

54−isValidAtomTypeForTypeConstructor aType (PrimitiveTypeConstructor _ expectedAType) _ = if expectedAType /= aType then Just (AtomTypeMismatchError expectedAType aType) else Nothing

55−

56−--lookup constructor name and check if the incoming atom types are valid

57−isValidAtomTypeForTypeConstructor (ConstructedAtomType tConsName _) (ADTypeConstructor expectedTConsName _) _ = if tConsName /= expectedTConsName then Just (TypeConstructorNameMismatch expectedTConsName tConsName) else Nothing

58−

59−isValidAtomTypeForTypeConstructor aType tCons _ = Just (AtomTypeTypeConstructorReconciliationError aType (TC.name tCons))

60−

6156-- | Used to determine if the atom arguments can be used with the data constructor.

62−-- | This is the entry point for type-checking from RelationalExpression.hs.

57+-- | This is the entry point for type-checking from RelationalExpression.hs

6358atomTypeForDataConstructor :: TypeConstructorMapping -> DataConstructorName -> [AtomType] -> Either RelationalError AtomType

6459atomTypeForDataConstructor tConss dConsName atomArgTypes =

6560 --lookup the data constructor

@@ -67,8 +62,12 @@ atomTypeForDataConstructor tConss dConsName atomArgTypes =

6762 Nothing -> Left (NoSuchDataConstructorError dConsName)

6863 Just (tCons, dCons) -> do

6964 --validate that the type constructor arguments are fulfilled in the data constructor

70− typeVars <- resolveDataConstructorTypeVars dCons atomArgTypes tConss

71− pure (ConstructedAtomType (TCD.name tCons) typeVars)

65+ dConsVars <- resolveDataConstructorTypeVars dCons atomArgTypes tConss

66+ let tConsVars = M.fromList (map (\v -> (v, TypeVariableType v)) (TCD.typeVars tCons))

67+ allVars = M.union dConsVars tConsVars

68+ unresolvedType = ConstructedAtomType (TCD.name tCons) allVars

69+ --validateAtomType unresolvedType tConss -- do not validate here because the type may not be fully resolved at this point

70+ pure unresolvedType

7271

7372-- | Walks the data and type constructors to extract the type variable map.

7473resolveDataConstructorTypeVars :: DataConstructorDef -> [AtomType] -> TypeConstructorMapping -> Either RelationalError TypeVarMap

@@ -82,10 +81,11 @@ resolveDataConstructorTypeVars dCons@(DataConstructorDef _ defArgs) aTypeArgs tC

8281 --if any two maps have the same key and different values, this indicates a type arg mismatch

8382 let typeVarMapFolder valMap acc = case acc of

8483 Left err -> Left err

85− Right accMap -> if accMap `M.isSubmapOf` valMap then

86− Right (M.union accMap valMap)

87− else

88− Left (DataConstructorTypeVarsMismatch (DCD.name dCons) accMap valMap)

84+ Right accMap ->

85+ case resolveAtomTypesInTypeVarMap valMap accMap of

86+ Left (TypeConstructorTypeVarMissing _) -> Left (DataConstructorTypeVarsMismatch (DCD.name dCons) accMap valMap)

87+ Left err -> Left err

88+ Right ok -> pure ok

8989 case foldr typeVarMapFolder (Right M.empty) maps of

9090 Left err -> Left err

9191 Right typeVarMaps -> pure typeVarMaps

@@ -116,8 +116,26 @@ resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) (ConstructedAtomT

116116 Right pVarMap'

117117 else

118118 Left (TypeConstructorTypeVarsMismatch expectedPVarNames (M.keysSet pVarMap'))

119−resolveTypeConstructorTypeVars (TypeVariable tvName) typ _ = Right (M.singleton tvName typ)

119+resolveTypeConstructorTypeVars (TypeVariable tvName) typ _ = case typ of

120+ TypeVariableType nam -> Left (TypeConstructorTypeVarMissing nam)

121+ _ -> Right (M.singleton tvName typ)

122+resolveTypeConstructorTypeVars (ADTypeConstructor tConsName []) typ tConss = case findTypeConstructor tConsName tConss of

123+ Just (PrimitiveTypeConstructorDef _ _, _) -> Right M.empty

124+ _ -> Left (TypeConstructorAtomTypeMismatch tConsName typ)

125+

120126resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) typ _ = Left (TypeConstructorAtomTypeMismatch tConsName typ)

127+

128+resolveTypeConstructorTypeVars (RelationAtomTypeConstructor attrExprs) typ tConsMap =

129+ case typ of

130+ RelationAtomType attrs ->

131+ --resolve any typevars in the attrExprs

132+ M.unions <$> mapM (\(expectedAtomType, attrExpr) -> resolveAttributeExprTypeVars attrExpr expectedAtomType tConsMap) (zip (A.atomTypesList attrs) attrExprs)

133+ otherType -> Left (AtomTypeMismatchError typ otherType)

134+

135+--used when recursing down sub-relation type definition

136+resolveAttributeExprTypeVars :: AttributeExprBase a -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap

137+resolveAttributeExprTypeVars (NakedAttributeExpr attr) aType _ = pure $ resolveTypeVariable (A.atomType attr) aType

138+resolveAttributeExprTypeVars (AttributeAndTypeNameExpr _ tCons _) aType tConsMap = resolveTypeConstructorTypeVars tCons aType tConsMap

121139

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

123141-- check that the data constructor names are unique

@@ -129,23 +147,49 @@ validateTypeConstructorDef tConsDef dConsList = execWriter $ do

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

130148 varsDiff = S.difference leftSideVars rightSideVars

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

132− pure ()

133−

150+

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

152+atomTypeForTypeConstructor = atomTypeForTypeConstructorValidate False

134153

135154-- | Create an atom type iff all type variables are provided.

136155-- Either Int Text -> ConstructedAtomType "Either" {Int , Text}

137−atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructorMapping -> TypeVarMap -> Either RelationalError AtomType

138−atomTypeForTypeConstructor (PrimitiveTypeConstructor _ aType) _ _ = Right aType

139−atomTypeForTypeConstructor (TypeVariable tvname) _ tvMap = case M.lookup tvname tvMap of

140− Nothing -> Right (TypeVariableType tvname)

156+atomTypeForTypeConstructorValidate :: Bool -> TypeConstructor -> TypeConstructorMapping -> TypeVarMap -> Either RelationalError AtomType

157+atomTypeForTypeConstructorValidate _ (PrimitiveTypeConstructor _ aType) _ _ = Right aType

158+atomTypeForTypeConstructorValidate validate (TypeVariable tvname) _ tvMap = case M.lookup tvname tvMap of

159+ Nothing -> if validate then

160+ Left (TypeConstructorTypeVarMissing tvname)

161+ else

162+ pure (TypeVariableType tvname)

141163 Just typ -> Right typ

142−atomTypeForTypeConstructor tCons tConss tvMap = case findTypeConstructor (TC.name tCons) tConss of

164+atomTypeForTypeConstructorValidate _ (RelationAtomTypeConstructor attrExprs) tConsMap tvMap = do

165+ resolvedAtomTypes <- mapM (\expr -> atomTypeForAttributeExpr expr tConsMap tvMap) attrExprs

166+ let attrs = zipWith Attribute (map AE.attributeName attrExprs) resolvedAtomTypes

167+ pure (RelationAtomType (A.attributesFromList attrs))

168+atomTypeForTypeConstructorValidate val tCons tConss tvMap = case findTypeConstructor (TC.name tCons) tConss of

143169 Nothing -> Left (NoSuchTypeConstructorError (TC.name tCons))

170+ Just (PrimitiveTypeConstructorDef _ aType, _) -> Right aType

144171 Just (tConsDef, _) -> do

145− tConsArgTypes <- mapM (\tConsArg -> atomTypeForTypeConstructor tConsArg tConss tvMap) (TC.arguments tCons)

146− let pVarNames = TCD.typeVars tConsDef

147− tConsArgs = M.fromList (zip pVarNames tConsArgTypes)

148− Right (ConstructedAtomType (TC.name tCons) tConsArgs)

172+ tConsArgTypes <- mapM (\tConsArg -> atomTypeForTypeConstructorValidate val tConsArg tConss tvMap) (TC.arguments tCons)

173+ let pVarNames = TCD.typeVars tConsDef

174+ tConsArgs = M.fromList (zip pVarNames tConsArgTypes)

175+ Right (ConstructedAtomType (TC.name tCons) tConsArgs)

176+

177+

178+atomTypeForAttributeExpr :: AttributeExprBase a -> TypeConstructorMapping -> TypeVarMap -> Either RelationalError AtomType

179+atomTypeForAttributeExpr (NakedAttributeExpr attr) _ _ = pure (A.atomType attr)

180+atomTypeForAttributeExpr (AttributeAndTypeNameExpr _ tCons _) tConsMap tvMap = atomTypeForTypeConstructorValidate True tCons tConsMap tvMap

181+

182+--reconcile the atom-in types with the type constructors

183+isValidAtomTypeForTypeConstructor :: AtomType -> TypeConstructor -> TypeConstructorMapping -> Either RelationalError ()

184+isValidAtomTypeForTypeConstructor aType (PrimitiveTypeConstructor _ expectedAType) _ = if expectedAType /= aType then Left (AtomTypeMismatchError expectedAType aType) else pure ()

185+

186+--lookup constructor name and check if the incoming atom types are valid

187+isValidAtomTypeForTypeConstructor (ConstructedAtomType tConsName _) (ADTypeConstructor expectedTConsName _) _ = if tConsName /= expectedTConsName then Left (TypeConstructorNameMismatch expectedTConsName tConsName) else pure ()

188+

189+isValidAtomTypeForTypeConstructor (RelationAtomType attrs) (RelationAtomTypeConstructor attrExprs) tConsMap = do

190+ evaldAtomTypes <- mapM (\expr -> atomTypeForAttributeExpr expr tConsMap M.empty) attrExprs

191+ mapM_ (uncurry resolveAtomType) (zip (map A.atomType (V.toList attrs)) evaldAtomTypes)

192+isValidAtomTypeForTypeConstructor aType tCons _ = Left (AtomTypeTypeConstructorReconciliationError aType (TC.name tCons))

149193

150194findTypeConstructor :: TypeConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, [DataConstructorDef])

151195findTypeConstructor name = foldr tConsFolder Nothing

@@ -156,15 +200,20 @@ findTypeConstructor name = foldr tConsFolder Nothing

156200 accum

157201

158202resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType

159−resolveAtomType (ConstructedAtomType tConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) = do

160− tVarMap <- resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

161− pure (ConstructedAtomType tConsName tVarMap)

203+resolveAtomType (ConstructedAtomType tConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) =

204+ ConstructedAtomType tConsName <$> resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

162205resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then

163206 Right typeFromRelation

164207 else

165208 Left (AtomTypeMismatchError typeFromRelation unresolvedType)

166209

167−-- this could be optimized to reduce new tuple creation- if anyatomtype does not appear, just return the original typevarmap

210+{-

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

212+resolveAtomTypeVars :: TypeVarMap -> AtomType -> AtomType

213+resolveAtomTypeVars tvMap typ@(TypeVariableType nam) = fromMaybe typ (M.lookup nam tvMap)

214+resolveAtomTypeVars tvMap (RelationAtomType relAttrs) =

215+-}

216+-- this could be optimized to reduce new tuple creation

168217resolveAtomTypesInTypeVarMap :: TypeVarMap -> TypeVarMap -> Either RelationalError TypeVarMap

169218resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do

170219 {-

@@ -185,24 +234,33 @@ resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do

185234 subType@(ConstructedAtomType _ _) -> do

186235 resSubType <- resolveAtomType resType subType

187236 pure (resKey, resSubType)

188− otherType -> pure (resKey, otherType)

237+ _ -> pure (resKey, resType)

189238 Nothing ->

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

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

192241 pure (M.fromList tVarList)

193242

194243-- | See notes at `resolveTypesInTuple`. The typeFromRelation must not include any wildcards.

195−resolveTypeInAtom :: AtomType -> Atom -> Either RelationalError Atom

196−resolveTypeInAtom typeFromRelation atomIn@(ConstructedAtom dConsName _ args) = do

244+resolveTypeInAtom :: AtomType -> Atom -> TypeConstructorMapping -> Either RelationalError Atom

245+resolveTypeInAtom typeFromRelation@(ConstructedAtomType _ tvMap) atomIn@(ConstructedAtom dConsName _ args) tConss = do

197246 newType <- resolveAtomType typeFromRelation (atomTypeForAtom atomIn)

198− pure (ConstructedAtom dConsName newType args)

199−resolveTypeInAtom _ atom = Right atom

247+ case findDataConstructor dConsName tConss of

248+ Nothing -> -- the atom may have been constructed using a constructor function without a public data constructor, no further resolution is possible

249+ pure atomIn

250+ Just (_, dConsDef) -> do

251+ atomArgTypes <- resolvedAtomTypesForDataConstructorDefArgs tConss tvMap dConsDef

252+ newArgs <- mapM (\(atom, atomTyp) -> resolveTypeInAtom atomTyp atom tConss) (zip args atomArgTypes)

253+ pure (ConstructedAtom dConsName newType newArgs)

254+resolveTypeInAtom (RelationAtomType attrs) (RelationAtom (Relation _ tupSet)) tConss = do

255+ let newTups = mapM (resolveTypesInTuple attrs tConss) (asList tupSet)

256+ RelationAtom . Relation attrs . RelationTupleSet <$> newTups

257+resolveTypeInAtom _ atom _ = Right atom

200258

201259-- | When creating a tuple, the data constructor may not complete the type constructor arguments, so the wildcard "TypeVar x" fills in the type constructor's argument. The tuple type must be resolved before it can be part of a relation, however.

202260-- Example: "Nothing" does not specify the the argument in "Maybe a", so allow delayed resolution in the tuple before it is added to the relation. Note that this resolution could cause a type error. Hardly a Hindley-Milner system.

203−resolveTypesInTuple :: Attributes -> RelationTuple -> Either RelationalError RelationTuple

204−resolveTypesInTuple resolvedAttrs (RelationTuple _ tupAtoms) = do

205− newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom) (zip (V.toList tupAtoms) $ map A.atomType (V.toList resolvedAttrs))

261+resolveTypesInTuple :: Attributes -> TypeConstructorMapping -> RelationTuple -> Either RelationalError RelationTuple

262+resolveTypesInTuple resolvedAttrs tConss (RelationTuple _ tupAtoms) = do

263+ newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom tConss) (zip (V.toList tupAtoms) $ map A.atomType (V.toList resolvedAttrs))

206264 Right (RelationTuple resolvedAttrs (V.fromList newAtoms))

207265

208266-- | Validate that the type is provided with complete type variables for type constructors.

@@ -217,12 +275,29 @@ validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss =

217275 if not (S.null diff) then

218276 Left $ TypeConstructorTypeVarsMismatch expectedTyVarNames actualTyVarNames

219277 else

220− Right ()

221− _ -> Right ()

222−validateAtomType _ _ = Right ()

278+ validateTypeVarMap tVarMap tConss

279+ _ -> Right ()

280+validateAtomType (RelationAtomType attrs) tConss =

281+ mapM_ (\attr ->

282+ validateAtomType (A.atomType attr) tConss) (V.toList attrs)

283+validateAtomType (TypeVariableType x) _ = Left (TypeConstructorTypeVarMissing x)

284+validateAtomType _ _ = pure ()

285+

286+--ensure that all type vars are fully resolved

287+validateTypeVarMap :: TypeVarMap -> TypeConstructorMapping -> Either RelationalError ()

288+validateTypeVarMap tvMap tConss = mapM_ (`validateAtomType` tConss) $ M.elems tvMap

223289

224290validateTuple :: RelationTuple -> TypeConstructorMapping -> Either RelationalError ()

225−validateTuple (RelationTuple _ atoms) tConss = mapM_ (\a -> validateAtomType (atomTypeForAtom a) tConss) atoms

291+validateTuple (RelationTuple _ atoms) tConss = mapM_ (`validateAtom` tConss) atoms

292+

293+--ensure that all types are fully resolved

294+validateAtom :: Atom -> TypeConstructorMapping -> Either RelationalError ()

295+validateAtom (RelationAtom (Relation _ tupSet)) tConss = mapM_ (`validateTuple` tConss) (asList tupSet)

296+validateAtom (ConstructedAtom _ dConsType atomArgs) tConss = do

297+ validateAtomType dConsType tConss

298+ mapM_ (`validateAtom` tConss) atomArgs

299+validateAtom _ _ = pure ()

300+

226301

227302-- | Determine if two types are equal or compatible (including special handling for TypeVar x).

228303atomTypeVerify :: AtomType -> AtomType -> Either RelationalError AtomType

@@ -241,7 +316,6 @@ atomTypeVerify x@(RelationAtomType attrs1) y@(RelationAtomType attrs2) = do

241316 else

242317 atomTypeVerify (A.atomType attr1) (A.atomType attr2)) $ V.toList (V.zip attrs1 attrs2)

243318 return x

244−atomTypeVerify (IntervalAtomType typA) (IntervalAtomType typB) = atomTypeVerify typA typB

245319atomTypeVerify x y = if x == y then

246320 Right x

247321 else

@@ -255,14 +329,15 @@ prettyAtomType :: AtomType -> T.Text

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

256330prettyAtomType (ConstructedAtomType tConsName typeVarMap) = tConsName `T.append` T.concat (map showTypeVars (M.toList typeVarMap))

257331 where

332+ showTypeVars (_, TypeVariableType x) = " " <> x

258333 showTypeVars (tyVarName, aType) = " (" `T.append` tyVarName `T.append` "::" `T.append` prettyAtomType aType `T.append` ")"

259334-- it would be nice to have the original ordering, but we don't have access to the type constructor here- maybe the typevarmap should be also positional (ordered map?)

260−prettyAtomType (TypeVariableType x) = "?TypeVariableType " <> x <> "?"

261−prettyAtomType (IntervalAtomType tv) = "Interval (" <> prettyAtomType tv <> ")"

335+prettyAtomType (TypeVariableType x) = x

262336prettyAtomType aType = T.take (T.length fullName - T.length "AtomType") fullName

263337 where fullName = (T.pack . show) aType

264338

265339prettyAttribute :: Attribute -> T.Text

340+prettyAttribute (Attribute _ (TypeVariableType x)) = x

266341prettyAttribute attr = A.attributeName attr `T.append` "::" `T.append` prettyAtomType (A.atomType attr)

267342

268343resolveTypeVariables :: [AtomType] -> [AtomType] -> Either RelationalError TypeVarMap

@@ -282,7 +357,6 @@ resolveTypeVariables expectedArgTypes actualArgTypes = do

282357

283358resolveTypeVariable :: AtomType -> AtomType -> TypeVarMap

284359resolveTypeVariable (TypeVariableType tv) typ = M.singleton tv typ

285−resolveTypeVariable (IntervalAtomType ityp) typ = resolveTypeVariable ityp typ

286360resolveTypeVariable (ConstructedAtomType _ _) (ConstructedAtomType _ actualTvMap) = actualTvMap

287361resolveTypeVariable _ _ = M.empty

288362

@@ -293,7 +367,6 @@ resolveFunctionReturnValue funcName tvMap (ConstructedAtomType tCons retMap) = d

293367 pure (ConstructedAtomType tCons (M.intersection tvMap retMap))

294368 else

295369 Left (AtomFunctionTypeVariableResolutionError funcName (fst (head (M.toList diff))))

296−resolveFunctionReturnValue funcName tvMap (IntervalAtomType tv) = IntervalAtomType <$> resolveFunctionReturnValue funcName tvMap tv

297370resolveFunctionReturnValue funcName tvMap (TypeVariableType tvName) = case M.lookup tvName tvMap of

298371 Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName tvName)

299372 Just typ -> pure typ

@@ -308,3 +381,4 @@ resolvedAtomTypeForDataConstructorDefArg tConsMap tvMap (DataConstructorDefTypeC

308381resolvedAtomTypeForDataConstructorDefArg _ tvMap (DataConstructorDefTypeVarNameArg tvName) = case M.lookup tvName tvMap of

309382 Nothing -> Left (DataConstructorUsesUndeclaredTypeVariable tvName)

310383 Just typ -> Right typ

384+

src/lib/ProjectM36/Atomable.hs+16−1

@@ -1,10 +1,12 @@

11{-# LANGUAGE DefaultSignatures, TypeFamilies, TypeOperators, PolyKinds, FlexibleInstances, ScopedTypeVariables, FlexibleContexts #-}

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

23module ProjectM36.Atomable where

34--http://stackoverflow.com/questions/13448361/type-families-with-ghc-generics-or-data-data

45--instances to marshal Haskell ADTs to ConstructedAtoms and back

56import ProjectM36.Base

67import ProjectM36.DataTypes.Primitive

78import ProjectM36.DataTypes.List

9+import ProjectM36.DataTypes.NonEmptyList

810import ProjectM36.DataTypes.Maybe

911import ProjectM36.DataTypes.Either

1012import GHC.Generics

@@ -18,6 +20,7 @@ import Data.ByteString (ByteString)

1820import Data.Time.Clock

1921import Data.Maybe

2022import Data.Proxy

23+import qualified Data.List.NonEmpty as NE

2124

2225--also add haskell scripting atomable support

2326--rename this module to Atomable along with test

@@ -155,6 +158,18 @@ instance Atomable a => Atomable [a] where

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

156159 toAddTypeExpr _ = NoOperation

157160

161+instance Atomable a => Atomable (NE.NonEmpty a) where

162+ toAtom (x NE.:| []) = ConstructedAtom "NECons" (nonEmptyListAtomType (toAtomType (Proxy :: Proxy a))) [toAtom x]

163+ toAtom (x NE.:| xs) = ConstructedAtom "NECons" (nonEmptyListAtomType (toAtomType (Proxy :: Proxy a))) (map toAtom (x:xs))

164+ fromAtom _ = error "improper fromAtom (NonEmptyList a)"

165+

166+ toAtomType _ = ConstructedAtomType "NonEmptyList" (M.singleton "a" (toAtomType (Proxy :: Proxy a)))

167+ toAddTypeExpr _ = NoOperation

168+

169+#if !MIN_VERSION_binary(0,8,4)

170+instance Binary a => Binary (NE.NonEmpty a)

171+#endif

172+

158173-- Generics

159174class AtomableG g where

160175 --type AtomTG g

@@ -229,7 +244,7 @@ instance (Atomable a) => AtomableG (K1 c a) where

229244 where

230245 tCons = PrimitiveTypeConstructor primitiveATypeName primitiveAType

231246 primitiveAType = toAtomType (Proxy :: Proxy a)

232− primitiveATypeName = fromMaybe (error ("primitive type missing: " ++ show primitiveAType)) (foldr (\(PrimitiveTypeConstructorDef name typ, _) _ -> if typ == primitiveAType then Just name else Nothing) Nothing primitiveTypeConstructorMapping)

247+ primitiveATypeName = fromMaybe (error ("primitive type missing: " ++ show primitiveAType)) (foldr (\(PrimitiveTypeConstructorDef name typ, _) acc -> if typ == primitiveAType then Just name else acc) Nothing primitiveTypeConstructorMapping)

233248

234249instance AtomableG U1 where

235250 toAtomG = undefined

src/lib/ProjectM36/Attribute.hs+5−2

@@ -29,6 +29,9 @@ atomType (Attribute _ atype) = atype

2929atomTypes :: Attributes -> V.Vector AtomType

3030atomTypes = V.map atomType

3131

32+atomTypesList :: Attributes -> [AtomType]

33+atomTypesList = V.toList . atomTypes

34+

3235--hm- no error-checking here

3336addAttribute :: Attribute -> Attributes -> Attributes

3437addAttribute attr attrs = attrs `V.snoc` attr

@@ -135,7 +138,7 @@ verifyAttributes attrs = if collapsedAttrs /= attrs then

135138 collapsedAttrs = vectorUniqueify attrs

136139

137140attributesEqual :: Attributes -> Attributes -> Bool

138−attributesEqual attrs1 attrs2 = V.null (attributesDifference attrs1 attrs2)

141+attributesEqual attrs1 attrs2 = V.null (attributesDifference attrs1 attrs2)

139142

140143attributesAsMap :: Attributes -> M.Map AttributeName Attribute

141144attributesAsMap attrs = (M.fromList . V.toList) (V.map (\attr -> (attributeName attr, attr)) attrs)

@@ -149,4 +152,4 @@ union attrsA attrsB = V.fromList (M.elems unioned)

149152intersection :: Attributes -> Attributes -> Attributes

150153intersection attrsA attrsB = V.fromList (M.elems intersected)

151154 where

152− intersected = M.intersection (attributesAsMap attrsA) (attributesAsMap attrsB)

155+ intersected = M.intersection (attributesAsMap attrsA) (attributesAsMap attrsB)

src/lib/ProjectM36/AttributeExpr.hsnew file+7

@@ -0,0 +1,7 @@

1+module ProjectM36.AttributeExpr where

2+import ProjectM36.Base

3+import ProjectM36.Attribute as A

4+

5+attributeName :: AttributeExprBase a -> AttributeName

6+attributeName (AttributeAndTypeNameExpr nam _ _) = nam

7+attributeName (NakedAttributeExpr attr) = A.attributeName attr

src/lib/ProjectM36/Base.hs+55−13

@@ -1,5 +1,6 @@

1−{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass, TypeSynonymInstances, FlexibleInstances #-}

1+{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,TypeSynonymInstances,FlexibleInstances,OverloadedStrings #-}

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

3+

34module ProjectM36.Base where

45import ProjectM36.DatabaseContextFunctionError

56import ProjectM36.AtomFunctionError

@@ -23,7 +24,6 @@ import Data.Time.Calendar (Day,toGregorian,fromGregorian)

2324import Data.Hashable.Time ()

2425import Data.Typeable

2526import Data.ByteString (ByteString)

26−

2727type StringType = Text

2828

2929-- | Database atoms are the smallest, undecomposable units of a tuple. Common examples are integers, text, or unique identity keys.

@@ -35,13 +35,10 @@ data Atom = IntegerAtom Integer |

3535 DateTimeAtom UTCTime |

3636 ByteStringAtom ByteString |

3737 BoolAtom Bool |

38− IntervalAtom Atom Atom OpenInterval OpenInterval |

3938 RelationAtom Relation |

4039 ConstructedAtom DataConstructorName AtomType [Atom]

4140 deriving (Eq, Show, Binary, Typeable, NFData, Generic)

4241

43−type OpenInterval = Bool

44−

4542instance Hashable Atom where

4643 hashWithSalt salt (ConstructedAtom dConsName _ atoms) = salt `hashWithSalt` atoms

4744 `hashWithSalt` dConsName --AtomType is not hashable

@@ -53,7 +50,6 @@ instance Hashable Atom where

5350 hashWithSalt salt (DateTimeAtom dt) = salt `hashWithSalt` dt

5451 hashWithSalt salt (ByteStringAtom bs) = salt `hashWithSalt` bs

5552 hashWithSalt salt (BoolAtom b) = salt `hashWithSalt` b

56− hashWithSalt salt (IntervalAtom a1 a2 bo be) = salt `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` bo `hashWithSalt` be

5753 hashWithSalt salt (RelationAtom r) = salt `hashWithSalt` r

5854

5955instance Binary UTCTime where

@@ -76,7 +72,6 @@ data AtomType = IntAtomType |

7672 DateTimeAtomType |

7773 ByteStringAtomType |

7874 BoolAtomType |

79− IntervalAtomType AtomType |

8075 RelationAtomType Attributes |

8176 ConstructedAtomType TypeConstructorName TypeVarMap |

8277 TypeVariableType TypeVarName

@@ -213,8 +208,10 @@ data RelationalExprBase a =

213208 --- | Returns the true relation iff

214209 Equals (RelationalExprBase a) (RelationalExprBase a) |

215210 NotEquals (RelationalExprBase a) (RelationalExprBase a) |

216− Extend (ExtendTupleExprBase a) (RelationalExprBase a)

211+ Extend (ExtendTupleExprBase a) (RelationalExprBase a) |

217212 --Summarize :: AtomExpr -> AttributeName -> RelationalExpr -> RelationalExpr -> RelationalExpr -- a special case of Extend

213+ --Evaluate relationalExpr with scoped views

214+ With [(RelVarName,RelationalExprBase a)] (RelationalExprBase a)

218215 deriving (Show, Eq, Generic, NFData)

219216

220217instance Binary RelationalExpr

@@ -238,9 +235,11 @@ data TypeConstructorDef = ADTypeConstructorDef TypeConstructorName [TypeVarName]

238235 deriving (Show, Generic, Binary, Eq, NFData)

239236

240237-- | Found in data constructors and type declarations: Left (Either Int Text) | Right Int

241−data TypeConstructor = ADTypeConstructor TypeConstructorName [TypeConstructor] |

242− PrimitiveTypeConstructor TypeConstructorName AtomType |

243− TypeVariable TypeVarName

238+type TypeConstructor = TypeConstructorBase ()

239+data TypeConstructorBase a = ADTypeConstructor TypeConstructorName [TypeConstructor] |

240+ PrimitiveTypeConstructor TypeConstructorName AtomType |

241+ RelationAtomTypeConstructor [AttributeExprBase a] |

242+ TypeVariable TypeVarName

244243 deriving (Show, Generic, Binary, Eq, NFData)

245244

246245type TypeConstructorMapping = [(TypeConstructorDef, DataConstructorDefs)]

@@ -332,12 +331,17 @@ data DatabaseContextExpr =

332331 MultipleExpr [DatabaseContextExpr]

333332 deriving (Show, Eq, Binary, Generic)

334333

334+type ObjModuleName = StringType

335+type ObjFunctionName = StringType

336+type Range = (Int,Int)

335337-- | Adding an atom function should be nominally a DatabaseExpr except for the fact that it cannot be performed purely. Thus, we create the DatabaseContextIOExpr.

336338data DatabaseContextIOExpr = AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript |

337− AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript

339+ LoadAtomFunctions ObjModuleName ObjFunctionName FilePath |

340+ AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript |

341+ LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath |

342+ CreateArbitraryRelation RelVarName [AttributeExpr] Range

338343 deriving (Show, Eq, Generic, Binary)

339344

340−

341345type RestrictionPredicateExpr = RestrictionPredicateExprBase ()

342346

343347-- | Restriction predicates are boolean algebra components which, when composed, indicate whether or not a tuple should be retained during a restriction (filtering) operation.

@@ -523,3 +527,41 @@ instance Hashable DatabaseContextFunction where

523527

524528instance Eq DatabaseContextFunction where

525529 f1 == f2 = dbcFuncName f1 == dbcFuncName f2

530+

531+attrTypeVars :: Attribute -> S.Set TypeVarName

532+attrTypeVars (Attribute _ aType) = case aType of

533+ IntAtomType -> S.empty

534+ IntegerAtomType -> S.empty

535+ DoubleAtomType -> S.empty

536+ TextAtomType -> S.empty

537+ DayAtomType -> S.empty

538+ DateTimeAtomType -> S.empty

539+ ByteStringAtomType -> S.empty

540+ BoolAtomType -> S.empty

541+ (RelationAtomType attrs) -> S.unions (map attrTypeVars (V.toList attrs))

542+ (ConstructedAtomType _ tvMap) -> M.keysSet tvMap

543+ (TypeVariableType nam) -> S.singleton nam

544+

545+typeVars :: TypeConstructor -> S.Set TypeVarName

546+typeVars (PrimitiveTypeConstructor _ _) = S.empty

547+typeVars (ADTypeConstructor _ args) = S.unions (map typeVars args)

548+typeVars (TypeVariable v) = S.singleton v

549+typeVars (RelationAtomTypeConstructor attrExprs) = S.unions (map attrExprTypeVars attrExprs)

550+

551+attrExprTypeVars :: AttributeExprBase a -> S.Set TypeVarName

552+attrExprTypeVars (AttributeAndTypeNameExpr _ tCons _) = typeVars tCons

553+attrExprTypeVars (NakedAttributeExpr attr) = attrTypeVars attr

554+

555+atomTypeVars :: AtomType -> S.Set TypeVarName

556+atomTypeVars IntAtomType = S.empty

557+atomTypeVars IntegerAtomType = S.empty

558+atomTypeVars DoubleAtomType = S.empty

559+atomTypeVars TextAtomType = S.empty

560+atomTypeVars DayAtomType = S.empty

561+atomTypeVars DateTimeAtomType = S.empty

562+atomTypeVars ByteStringAtomType = S.empty

563+atomTypeVars BoolAtomType = S.empty

564+atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList attrs))

565+atomTypeVars (ConstructedAtomType _ tvMap) = M.keysSet tvMap

566+atomTypeVars (TypeVariableType nam) = S.singleton nam

567+

src/lib/ProjectM36/Client.hs+70−35

@@ -25,6 +25,7 @@ module ProjectM36.Client

2525 typeForRelationalExpr,

2626 inclusionDependencies,

2727 ProjectM36.Client.typeConstructorMapping,

28+ ProjectM36.Client.databaseContextFunctionsAsRelation,

2829 planForDatabaseContextExpr,

2930 currentSchemaName,

3031 SchemaName,

@@ -32,6 +33,7 @@ module ProjectM36.Client

3233 setCurrentSchemaName,

3334 transactionGraphAsRelation,

3435 relationVariablesAsRelation,

36+ ProjectM36.Client.atomFunctionsAsRelation,

3537 disconnectedTransactionIsDirty,

3638 headName,

3739 remoteDBLookupName,

@@ -76,7 +78,7 @@ module ProjectM36.Client

7678 databaseContextExprForForeignKey,

7779 createScriptedAtomFunction,

7880 AttributeExprBase(..),

79− TypeConstructor(..),

81+ TypeConstructorBase(..),

8082 TypeConstructorDef(..),

8183 DataConstructorDef(..),

8284 AttributeNamesBase(..),

@@ -98,9 +100,10 @@ import ProjectM36.Base hiding (inclusionDependencies) --defined in this module a

98100import qualified ProjectM36.Base as B

99101import ProjectM36.Error

100102import ProjectM36.Atomable

101−import ProjectM36.AtomFunction

103+import ProjectM36.AtomFunction as AF

102104import ProjectM36.StaticOptimizer

103105import ProjectM36.Key

106+import ProjectM36.DatabaseContextFunction as DCF

104107import qualified ProjectM36.IsomorphicSchema as Schema

105108import Control.Monad.State

106109import Control.Monad.Trans.Reader

@@ -125,8 +128,14 @@ import Control.Exception.Base

125128import GHC.Conc.Sync

126129

127130import Network.Transport (Transport(closeTransport))

128−import Network.Transport.TCP.Internal (encodeEndPointAddress)

131+

132+#if MIN_VERSION_network_transport_tcp(0,6,0)

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

134+import Network.Transport.TCP.Internal (encodeEndPointAddress)

135+#else

136+import Network.Transport.TCP (encodeEndPointAddress, createTransport, defaultTCPParameters)

137+#endif

138+

130139import Control.Distributed.Process.Node (newLocalNode, initRemoteTable, runProcess, LocalNode, forkProcess, closeLocalNode)

131140import Control.Distributed.Process.Extras.Internal.Types (whereisRemote)

132141import Control.Distributed.Process.ManagedProcess.Client (call, safeCall)

@@ -138,8 +147,8 @@ import Control.Exception (IOException, handle, AsyncException, throwIO, fromExce

138147import Control.Concurrent.MVar

139148import qualified Data.Map as M

140149import Control.Distributed.Process.Serializable (Serializable)

141−import qualified STMContainers.Map as STMMap

142−import qualified STMContainers.Set as STMSet

150+import qualified StmContainers.Map as StmMap

151+import qualified StmContainers.Set as StmSet

143152import qualified ProjectM36.Session as Sess

144153import ProjectM36.Session

145154import ProjectM36.Sessions

@@ -215,7 +224,7 @@ defaultRemoteConnectionInfo :: ConnectionInfo

215224defaultRemoteConnectionInfo = RemoteProcessConnectionInfo defaultDatabaseName (createNodeId "127.0.0.1" defaultServerPort) emptyNotificationCallback

216225

217226-- | The 'Connection' represents either local or remote access to a database. All operations flow through the connection.

218−type ClientNodes = STMSet.Set ProcessId

227+type ClientNodes = StmSet.Set ProcessId

219228

220229-- internal structure specific to in-process connections

221230data InProcessConnectionConf = InProcessConnectionConf {

@@ -250,7 +259,11 @@ remoteDBLookupName = (++) "db-"

250259

251260createLocalNode :: IO (LocalNode, Transport)

252261createLocalNode = do

253− eLocalTransport <- createTransport "127.0.0.1" "0" (\sn -> ("127.0.0.1",sn)) defaultTCPParameters

262+#if MIN_VERSION_network_transport_tcp(0,6,0)

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

264+#else

265+ eLocalTransport <- createTransport "127.0.0.1" "0" defaultTCPParameters

266+#endif

254267 case eLocalTransport of

255268 Left err -> error ("failed to create transport: " ++ show err)

256269 Right localTransport -> do

@@ -294,8 +307,8 @@ connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPath

294307 --create date examples graph for now- probably should be empty context in the future

295308 NoPersistence -> do

296309 graphTvar <- newTVarIO freshGraph

297− clientNodes <- STMSet.newIO

298− sessions <- STMMap.newIO

310+ clientNodes <- StmSet.newIO

311+ sessions <- StmMap.newIO

299312 (localNode, transport) <- createLocalNode

300313 notificationPid <- startNotificationListener localNode notificationCallback

301314 mScriptSession <- createScriptSession ghcPkgPaths

@@ -331,8 +344,7 @@ connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId notific

331344 liftIO $ putMVar connStatus (Left LoginError)

332345 else

333346 liftIO $ putMVar connStatus (Right $ RemoteProcessConnection RemoteProcessConnectionConf {rLocalNode = localNode, rProcessId = serverProcessId, rTransport = transport})

334− status <- takeMVar connStatus

335− pure status

347+ takeMVar connStatus

336348

337349connectPersistentProjectM36 :: PersistenceStrategy ->

338350 DiskSync ->

@@ -352,8 +364,8 @@ connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback ghc

352364 Left err' -> return $ Left (SetupDatabaseDirectoryError err')

353365 Right graph' -> do

354366 tvarGraph <- newTVarIO graph'

355− sessions <- STMMap.newIO

356− clientNodes <- STMSet.newIO

367+ sessions <- StmMap.newIO

368+ clientNodes <- StmSet.newIO

357369 (localNode, transport) <- createLocalNode

358370 lockMVar <- newMVar digest

359371 let conn = InProcessConnection InProcessConnectionConf {

@@ -387,11 +399,11 @@ createSessionAtCommit_ commitId newSessionId (InProcessConnection conf) = do

387399 Left err -> pure (Left err)

388400 Right transaction -> do

389401 let freshDiscon = DisconnectedTransaction commitId (Trans.schemas transaction) False

390− keyDuplication <- STMMap.lookup newSessionId sessions

402+ keyDuplication <- StmMap.lookup newSessionId sessions

391403 case keyDuplication of

392404 Just _ -> pure $ Left (SessionIdInUseError newSessionId)

393405 Nothing -> do

394− STMMap.insert (Session freshDiscon defaultSchemaName) newSessionId sessions

406+ StmMap.insert (Session freshDiscon defaultSchemaName) newSessionId sessions

395407 pure $ Right newSessionId

396408createSessionAtCommit_ _ _ (RemoteProcessConnection _) = error "createSessionAtCommit_ called on remote connection"

397409

@@ -410,12 +422,12 @@ createSessionAtHead conn@(RemoteProcessConnection _) headn = remoteCall conn (Cr

410422-- | Used internally for server connections to keep track of remote nodes for the purpose of sending notifications later.

411423addClientNode :: Connection -> ProcessId -> IO ()

412424addClientNode (RemoteProcessConnection _) _ = error "addClientNode called on remote connection"

413−addClientNode (InProcessConnection conf) newProcessId = atomically (STMSet.insert newProcessId (ipClientNodes conf))

425+addClientNode (InProcessConnection conf) newProcessId = atomically (StmSet.insert newProcessId (ipClientNodes conf))

414426

415427-- | Discards a session, eliminating any uncommitted changes present in the session.

416428closeSession :: SessionId -> Connection -> IO ()

417429closeSession sessionId (InProcessConnection conf) =

418− atomically $ STMMap.delete sessionId (ipSessions conf)

430+ atomically $ StmMap.delete sessionId (ipSessions conf)

419431closeSession sessionId conn@(RemoteProcessConnection _) = remoteCall conn (CloseSession sessionId)

420432

421433-- | 'close' cleans up the database access connection and closes any relevant sockets.

@@ -423,7 +435,7 @@ close :: Connection -> IO ()

423435close (InProcessConnection conf) = do

424436 atomically $ do

425437 let sessions = ipSessions conf

426− STMMap.deleteAll sessions

438+ StmMap.reset sessions

427439 pure ()

428440 closeLocalNode (ipLocalNode conf)

429441 closeTransport (ipTransport conf)

@@ -482,9 +494,8 @@ remoteCall (RemoteProcessConnection conf) arg = runProcessResult localNode $ do

482494 serverProcessId = rProcessId conf

483495

484496sessionForSessionId :: SessionId -> Sessions -> STM (Either RelationalError Session)

485−sessionForSessionId sessionId sessions = do

486− maybeSession <- STMMap.lookup sessionId sessions

487− pure $ maybe (Left $ NoSuchSessionError sessionId) Right maybeSession

497+sessionForSessionId sessionId sessions =

498+ maybe (Left $ NoSuchSessionError sessionId) Right <$> StmMap.lookup sessionId sessions

488499

489500schemaForSessionId :: Session -> STM (Either RelationalError Schema)

490501schemaForSessionId session = do

@@ -526,7 +537,7 @@ setCurrentSchemaName sessionId (InProcessConnection conf) sname = atomically $ d

526537 Left err -> pure (Left err)

527538 Right session -> case Sess.setSchemaName sname session of

528539 Left err -> pure (Left err)

529− Right newSession -> STMMap.insert newSession sessionId sessions >> pure (Right ())

540+ Right newSession -> StmMap.insert newSession sessionId sessions >> pure (Right ())

530541setCurrentSchemaName sessionId conn@(RemoteProcessConnection _) sname = remoteCall conn (ExecuteSetCurrentSchema sessionId sname)

531542

532543-- | Execute a relational expression in the context of the session and connection. Relational expressions are queries and therefore cannot alter the database.

@@ -579,7 +590,7 @@ executeDatabaseContextExpr sessionId (InProcessConnection conf) expr = excEither

579590 newSubschemas = Schema.processDatabaseContextExprSchemasUpdate (Sess.subschemas session) expr

580591 newSchemas = Schemas context' newSubschemas

581592 newSession = Session newDiscon (Sess.schemaName session)

582− STMMap.insert newSession sessionId sessions

593+ StmMap.insert newSession sessionId sessions

583594 pure (Right ())

584595executeDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr)

585596

@@ -629,7 +640,7 @@ executeDatabaseContextIOExpr sessionId (InProcessConnection conf) expr = excEith

629640 let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas True

630641 newSchemas = Schemas context' (Sess.subschemas session)

631642 newSession = Session newDiscon (Sess.schemaName session)

632− atomically $ STMMap.insert newSession sessionId sessions

643+ atomically $ StmMap.insert newSession sessionId sessions

633644 pure (Right ())

634645executeDatabaseContextIOExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextIOExpr sessionId dbExpr)

635646

@@ -740,7 +751,7 @@ executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do

740751 Left err -> pure $ Left err

741752 Right previousTrans -> do

742753 (evaldNots, nodes) <- executeCommitExprSTM_ (Trans.concreteDatabaseContext previousTrans) (Sess.concreteDatabaseContext session) clientNodes

743− nodesToNotify <- toList (STMSet.stream nodes)

754+ nodesToNotify <- toList (StmSet.stream nodes)

744755 pure $ Right (evaldNots, nodesToNotify, newGraph)

745756 else

746757 pure $ Right (M.empty, [], newGraph)

@@ -782,7 +793,7 @@ executeSchemaExpr sessionId (InProcessConnection conf) schemaExpr = atomically $

782793 let discon = Sess.disconnectedTransaction session

783794 newSchemas = Schemas newContext newSubschemas

784795 newSession = Session (DisconnectedTransaction (Discon.parentId discon) newSchemas True) (Sess.schemaName session)

785− STMMap.insert newSession sessionId sessions

796+ StmMap.insert newSession sessionId sessions

786797 pure (Right ())

787798executeSchemaExpr sessionId conn@(RemoteProcessConnection _) schemaExpr = remoteCall conn (ExecuteSchemaExpr sessionId schemaExpr)

788799

@@ -891,9 +902,8 @@ transactionGraphAsRelation sessionId (InProcessConnection conf) = do

891902 eSession <- sessionForSessionId sessionId sessions

892903 case eSession of

893904 Left err -> pure $ Left err

894− Right session -> do

895− graph <- readTVar tvar

896− pure $ graphAsRelation (Sess.disconnectedTransaction session) graph

905+ Right session ->

906+ graphAsRelation (Sess.disconnectedTransaction session) <$> readTVar tvar

897907

898908transactionGraphAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveTransactionGraph sessionId)

899909

@@ -914,7 +924,32 @@ relationVariablesAsRelation sessionId (InProcessConnection conf) = do

914924 Left err -> pure (Left err)

915925 Right relvars -> pure $ R.relationVariablesAsRelation relvars

916926

917−relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId)

927+relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId)

928+

929+-- | Returns the names and types of the atom functions in the current 'Session'.

930+atomFunctionsAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

931+atomFunctionsAsRelation sessionId (InProcessConnection conf) = do

932+ let sessions = ipSessions conf

933+ atomically $ do

934+ eSession <- sessionAndSchema sessionId sessions

935+ case eSession of

936+ Left err -> pure (Left err)

937+ Right (session, _) ->

938+ pure (AF.atomFunctionsAsRelation (atomFunctions (concreteDatabaseContext session)))

939+

940+atomFunctionsAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveAtomFunctionSummary sessionId)

941+

942+databaseContextFunctionsAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

943+databaseContextFunctionsAsRelation sessionId (InProcessConnection conf) = do

944+ let sessions = ipSessions conf

945+ atomically $ do

946+ eSession <- sessionAndSchema sessionId sessions

947+ case eSession of

948+ Left err -> pure (Left err)

949+ Right (session, _) ->

950+ pure (DCF.databaseContextFunctionsAsRelation (dbcFunctions (concreteDatabaseContext session)))

951+

952+databaseContextFunctionsAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveDatabaseContextFunctionSummary sessionId)

918953

919954-- | Returns the transaction id for the connection's disconnected transaction committed parent transaction.

920955headTransactionId :: SessionId -> Connection -> IO (Either RelationalError TransactionId)

@@ -979,14 +1014,14 @@ callTestTimeout_ sessionId conn@(RemoteProcessConnection _) = remoteCall conn (T

9791014

9801015--used in tests only

9811016transactionGraph_ :: Connection -> IO TransactionGraph

982−transactionGraph_ (InProcessConnection conf) = atomically $ readTVar (ipTransactionGraph conf)

1017+transactionGraph_ (InProcessConnection conf) = readTVarIO (ipTransactionGraph conf)

9831018transactionGraph_ _ = error "remote connection used"

9841019

9851020--used in tests only

9861021disconnectedTransaction_ :: SessionId -> Connection -> IO DisconnectedTransaction

9871022disconnectedTransaction_ sessionId (InProcessConnection conf) = do

9881023 let sessions = ipSessions conf

989− mSession <- atomically $ STMMap.lookup sessionId sessions

1024+ mSession <- atomically $ StmMap.lookup sessionId sessions

9901025 case mSession of

9911026 Nothing -> error "No such session"

9921027 Just (Sess.Session discon _) -> pure discon

@@ -1044,13 +1079,13 @@ commitLock_ sessionId conf stmBlock = do

10441079 Right (discon', graph', transactionIdsToPersist) -> do

10451080 writeTVar graphTvar graph'

10461081 let newSession = Session discon' (Sess.schemaName session)

1047− STMMap.insert newSession sessionId sessions

1082+ StmMap.insert newSession sessionId sessions

10481083 case transactionForId (Sess.parentId session) oldGraph of

10491084 Left err -> pure $ Left err

10501085 Right previousTrans ->

10511086 if not (Prelude.null transactionIdsToPersist) then do

10521087 (evaldNots, nodes) <- executeCommitExprSTM_ (Trans.concreteDatabaseContext previousTrans) (Sess.concreteDatabaseContext session) clientNodes

1053− nodesToNotify <- toList (STMSet.stream nodes)

1088+ nodesToNotify <- stmSetToList nodes

10541089 pure $ Right (evaldNots, nodesToNotify, graph', transactionIdsToPersist)

10551090 else pure (Right (M.empty, [], graph', []))

10561091

@@ -1067,7 +1102,7 @@ writeDisconAndGraph_ :: TVar TransactionGraph -> SessionId -> Session -> Session

10671102writeDisconAndGraph_ graphTvar sessionId session sessions discon graph = do

10681103 writeTVar graphTvar graph

10691104 let newSession = Session discon (Sess.schemaName session)

1070− STMMap.insert newSession sessionId sessions

1105+ StmMap.insert newSession sessionId sessions

10711106-}

10721107

10731108-- | Runs an IO monad, commits the result when the monad returns no errors, otherwise, rolls back the changes and the error.

src/lib/ProjectM36/DataConstructorDef.hs+2−3

@@ -1,6 +1,5 @@

11module ProjectM36.DataConstructorDef where

2−import ProjectM36.Base

3−import qualified ProjectM36.TypeConstructor as TC

2+import ProjectM36.Base as B

43import qualified Data.Set as S

54

65emptyDataConstructor :: DataConstructorName -> DataConstructorDef

@@ -16,6 +15,6 @@ typeVars :: DataConstructorDef -> S.Set TypeVarName

1615typeVars (DataConstructorDef _ tConsArgs) = S.unions $ map typeVarsInDefArg tConsArgs

1716

1817typeVarsInDefArg :: DataConstructorDefArg -> S.Set TypeVarName

19−typeVarsInDefArg (DataConstructorDefTypeConstructorArg tCons) = TC.typeVars tCons

18+typeVarsInDefArg (DataConstructorDefTypeConstructorArg tCons) = B.typeVars tCons

2019typeVarsInDefArg (DataConstructorDefTypeVarNameArg pVarName) = S.singleton pVarName

2120

src/lib/ProjectM36/DataTypes/Basic.hs+4−2

@@ -1,10 +1,11 @@

11-- wraps up primitives plus other basic data types

22module ProjectM36.DataTypes.Basic where

33import ProjectM36.DataTypes.Primitive

4−import ProjectM36.DataTypes.Day

54import ProjectM36.DataTypes.Either

65import ProjectM36.DataTypes.Maybe

76import ProjectM36.DataTypes.List

7+import ProjectM36.DataTypes.NonEmptyList

8+import ProjectM36.DataTypes.Interval

89import ProjectM36.Base

910

1011basicTypeConstructorMapping :: TypeConstructorMapping

@@ -12,6 +13,7 @@ basicTypeConstructorMapping = primitiveTypeConstructorMapping ++

1213 maybeTypeConstructorMapping ++

1314 eitherTypeConstructorMapping ++

1415 listTypeConstructorMapping ++

15− dayTypeConstructorMapping

16+ nonEmptyListTypeConstructorMapping ++

17+ intervalTypeConstructorMapping

1618

1719

src/lib/ProjectM36/DataTypes/Day.hs+2−5

@@ -7,14 +7,11 @@ import Data.Time.Calendar

77dayAtomFunctions :: AtomFunctions

88dayAtomFunctions = HS.fromList [

99 AtomFunction { atomFuncName = "fromGregorian",

10− atomFuncType = [IntAtomType, IntAtomType, IntAtomType, DayAtomType],

11− atomFuncBody = compiledAtomFunctionBody $ \(IntAtom year:IntAtom month:IntAtom day:_) -> pure $ DayAtom (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day))

10+ atomFuncType = [IntegerAtomType, IntegerAtomType, IntegerAtomType, DayAtomType],

11+ atomFuncBody = compiledAtomFunctionBody $ \(IntegerAtom year:IntegerAtom month:IntegerAtom day:_) -> pure $ DayAtom (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day))

1212 },

1313 AtomFunction { atomFuncName = "dayEarlierThan",

1414 atomFuncType = [DayAtomType, DayAtomType, BoolAtomType],

1515 atomFuncBody = compiledAtomFunctionBody $ \(ConstructedAtom _ _ (IntAtom dayA:_):ConstructedAtom _ _ (IntAtom dayB:_):_) -> pure (BoolAtom (dayA < dayB))

1616 }

1717 ]

18−

19−dayTypeConstructorMapping :: TypeConstructorMapping

20−dayTypeConstructorMapping = [] -- use fromGregorian

src/lib/ProjectM36/DataTypes/Interval.hs+55−19

@@ -6,7 +6,24 @@ import ProjectM36.AtomType

66import ProjectM36.DataTypes.Primitive

77import ProjectM36.AtomFunctionError

88import qualified Data.HashSet as HS

9+import qualified Data.Map as M

10+import Control.Monad (when)

11+import Data.Maybe

912

13+type OpenInterval = Bool

14+

15+intervalSubType :: AtomType -> AtomType

16+intervalSubType typ = if isIntervalAtomType typ then

17+ case typ of

18+ ConstructedAtomType _ tvMap ->

19+ fromMaybe err (M.lookup "a" tvMap)

20+ _ -> err

21+ else

22+ err

23+ where

24+ err = error "intervalSubType on non-interval type"

25+

26+

1027-- in lieu of typeclass support, we just hard-code the types which can be part of an interval

1128supportsInterval :: AtomType -> Bool

1229supportsInterval typ = case typ of

@@ -18,7 +35,6 @@ supportsInterval typ = case typ of

1835 DateTimeAtomType -> True

1936 ByteStringAtomType -> False

2037 BoolAtomType -> False

21− IntervalAtomType _ -> False

2238 RelationAtomType _ -> False

2339 ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this

2440 TypeVariableType _ -> False

@@ -33,7 +49,6 @@ supportsOrdering typ = case typ of

3349 DateTimeAtomType -> True

3450 ByteStringAtomType -> False

3551 BoolAtomType -> False

36− IntervalAtomType _ -> False

3752 RelationAtomType _ -> False

3853 ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this

3954 TypeVariableType _ -> False

@@ -67,7 +82,11 @@ createInterval atom1 atom2 bopen eopen = do

6782 else

6883 Right valid

6984 LT -> Right valid

70− where valid = IntervalAtom atom1 atom2 bopen eopen

85+ where valid = ConstructedAtom "Interval" iType [atom1, atom2, BoolAtom bopen, BoolAtom eopen]

86+ iType = intervalAtomType (atomTypeForAtom atom1)

87+

88+intervalAtomType :: AtomType -> AtomType

89+intervalAtomType typ = ConstructedAtomType "Interval" (M.singleton "a" typ)

7190

7291intervalAtomFunctions :: AtomFunctions

7392intervalAtomFunctions = HS.fromList [

@@ -76,7 +95,7 @@ intervalAtomFunctions = HS.fromList [

7695 TypeVariableType "a",

7796 BoolAtomType,

7897 BoolAtomType,

79− IntervalAtomType (TypeVariableType "a")],

98+ intervalAtomType (TypeVariableType "a")],

8099 atomFuncBody = compiledAtomFunctionBody $ \(atom1:atom2:BoolAtom bopen:BoolAtom eopen:_) -> do

81100 let aType = atomTypeForAtom atom1

82101 if supportsInterval aType then

@@ -86,23 +105,40 @@ intervalAtomFunctions = HS.fromList [

86105 },

87106 AtomFunction {

88107 atomFuncName = "interval_overlaps",

89− atomFuncType = [IntervalAtomType (TypeVariableType "a"),

90− IntervalAtomType (TypeVariableType "a"),

108+ atomFuncType = [intervalAtomType (TypeVariableType "a"),

109+ intervalAtomType (TypeVariableType "a"),

91110 BoolAtomType],

92− atomFuncBody = compiledAtomFunctionBody $ \(i1@IntervalAtom{}:i2@IntervalAtom{}:_) -> do

93− res <- intervalOverlaps i1 i2

94− pure (BoolAtom res)

111+ atomFuncBody = compiledAtomFunctionBody $ \(i1@ConstructedAtom{}:i2@ConstructedAtom{}:_) ->

112+ BoolAtom <$> intervalOverlaps i1 i2

95113 }]

96−

97−

114+

115+isIntervalAtomType :: AtomType -> Bool

116+isIntervalAtomType (ConstructedAtomType nam tvMap) =

117+ nam == "Interval" && M.keys tvMap == ["a"] && case M.lookup "a" tvMap of

118+ Nothing -> False

119+ Just subType -> supportsInterval subType || subType == TypeVariableType "a"

120+isIntervalAtomType _ = False

121+

98122intervalOverlaps :: Atom -> Atom -> Either AtomFunctionError Bool

99−intervalOverlaps (IntervalAtom i1start i1end i1startopen i1endopen) (IntervalAtom i2start i2end i2startopen i2endopen) = do

100− cmp1 <- atomCompare i1start i2end

101− cmp2 <- atomCompare i2start i1end

102− let startcmp = if i1startopen || i2endopen then oplt else oplte

103− endcmp = if i2startopen || i1endopen then oplt else oplte

104− oplte op = op == LT || op == EQ

105− oplt op = op == LT

106− pure (startcmp cmp1 && endcmp cmp2)

123+intervalOverlaps (ConstructedAtom dCons1 typ1 [i1start,

124+ i1end,

125+ BoolAtom i1startopen,

126+ BoolAtom i1endopen]) (ConstructedAtom dCons2 typ2

127+ [i2start,

128+ i2end,

129+ BoolAtom i2startopen,

130+ BoolAtom i2endopen]) = do

131+ when (dCons1 /= "Interval" || dCons2 /= "Interval" || not (isIntervalAtomType typ1) || not (isIntervalAtomType typ2)) (Left AtomFunctionTypeMismatchError)

132+ cmp1 <- atomCompare i1start i2end

133+ cmp2 <- atomCompare i2start i1end

134+ let startcmp = if i1startopen || i2endopen then oplt else oplte

135+ endcmp = if i2startopen || i1endopen then oplt else oplte

136+ oplte op = op == LT || op == EQ

137+ oplt op = op == LT

138+ pure (startcmp cmp1 && endcmp cmp2)

107139intervalOverlaps _ _ = Left AtomFunctionTypeMismatchError

108140

141+intervalTypeConstructorMapping :: TypeConstructorMapping

142+intervalTypeConstructorMapping = [(ADTypeConstructorDef "Interval" ["a"], [])]

143+

144+

src/lib/ProjectM36/DataTypes/List.hs+2−3

@@ -37,9 +37,8 @@ listAtomFunctions = HS.fromList [

3737 AtomFunction {

3838 atomFuncName = "length",

3939 atomFuncType = [listAtomType (TypeVariableType "a"), IntAtomType],

40− atomFuncBody = AtomFunctionBody Nothing (\(listAtom:_) -> do

41− c <- listLength listAtom

42− pure (IntAtom (fromIntegral c)))

40+ atomFuncBody = AtomFunctionBody Nothing (\(listAtom:_) ->

41+ IntAtom . fromIntegral <$> listLength listAtom)

4342 },

4443 AtomFunction {

4544 atomFuncName = "maybeHead",

src/lib/ProjectM36/DataTypes/NonEmptyList.hsnew file+53

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

1+module ProjectM36.DataTypes.NonEmptyList where

2+import ProjectM36.Base

3+import qualified Data.Map as M

4+import qualified Data.HashSet as HS

5+import ProjectM36.AtomFunctionError

6+import ProjectM36.DataTypes.List

7+

8+nonEmptyListAtomType :: AtomType -> AtomType

9+nonEmptyListAtomType arg = ConstructedAtomType "NonEmptyList" (M.singleton "a" arg)

10+

11+-- data NonEmptyList = NECons a (Cons a)

12+nonEmptyListTypeConstructorMapping :: TypeConstructorMapping

13+nonEmptyListTypeConstructorMapping = [(ADTypeConstructorDef "NonEmptyList" ["a"],

14+ [DataConstructorDef "NECons" [DataConstructorDefTypeVarNameArg "a",

15+ DataConstructorDefTypeConstructorArg (ADTypeConstructor "List" [TypeVariable "a"])]])]

16+

17+nonEmptyListLength :: Atom -> Either AtomFunctionError Int

18+nonEmptyListLength (ConstructedAtom "NECons" _ (_:nextCons:_)) = do

19+ c <- listLength nextCons

20+ pure (c + 1)

21+nonEmptyListLength (ConstructedAtom "NECons" _ _) = pure 1

22+nonEmptyListLength _ = Left AtomFunctionTypeMismatchError

23+

24+nonEmptyListHead :: Atom -> Either AtomFunctionError Atom

25+nonEmptyListHead (ConstructedAtom "NECons" _ (val:_)) = pure val

26+nonEmptyListHead _ = Left AtomFunctionTypeMismatchError

27+

28+{-

29+listMaybeHead :: Atom -> Either AtomFunctionError Atom

30+listMaybeHead (ConstructedAtom "Cons" _ (val:_)) = pure (ConstructedAtom "Just" aType [val])

31+ where

32+ aType = maybeAtomType (atomTypeForAtom val)

33+listMaybeHead (ConstructedAtom "Empty" (ConstructedAtomType _ tvMap) _) =

34+ case M.lookup "a" tvMap of

35+ Nothing -> Left AtomFunctionTypeMismatchError

36+ Just aType -> pure (ConstructedAtom "Nothing" aType [])

37+listMaybeHead _ = Left AtomFunctionTypeMismatchError

38+-}

39+

40+nonEmptyListAtomFunctions :: AtomFunctions

41+nonEmptyListAtomFunctions = HS.fromList [

42+ AtomFunction {

43+ atomFuncName = "nonEmptyListLength",

44+ atomFuncType = [nonEmptyListAtomType (TypeVariableType "a"), IntAtomType],

45+ atomFuncBody = AtomFunctionBody Nothing (\(nonEmptyListAtom:_) ->

46+ IntAtom . fromIntegral <$> nonEmptyListLength nonEmptyListAtom)

47+ },

48+ AtomFunction {

49+ atomFuncName = "nonEmptyListHead",

50+ atomFuncType = [nonEmptyListAtomType (TypeVariableType "a"), TypeVariableType "a"],

51+ atomFuncBody = AtomFunctionBody Nothing (\(nonEmptyListAtom:_) -> nonEmptyListHead nonEmptyListAtom)

52+ }

53+ ]

src/lib/ProjectM36/DataTypes/Primitive.hs+6−2

@@ -10,7 +10,9 @@ primitiveTypeConstructorMapping = map (\(name, aType) ->

1010 ("Text", TextAtomType),

1111 ("Double", DoubleAtomType),

1212 ("Bool", BoolAtomType),

13− ("ByteString", ByteStringAtomType)

13+ ("ByteString", ByteStringAtomType),

14+ ("DateTime", DateTimeAtomType),

15+ ("Day", DayAtomType)

1416 ]

1517

1618intTypeConstructor :: TypeConstructor

@@ -25,6 +27,9 @@ textTypeConstructor = PrimitiveTypeConstructor "Text" TextAtomType

2527dayTypeConstructor :: TypeConstructor

2628dayTypeConstructor = PrimitiveTypeConstructor "Day" DayAtomType

2729

30+dateTimeTypeConstructor :: TypeConstructor

31+dateTimeTypeConstructor = PrimitiveTypeConstructor "DateTime" DayAtomType

32+

2833-- | Return the type of an 'Atom'.

2934atomTypeForAtom :: Atom -> AtomType

3035atomTypeForAtom (IntAtom _) = IntAtomType

@@ -35,6 +40,5 @@ atomTypeForAtom (DayAtom _) = DayAtomType

3540atomTypeForAtom (DateTimeAtom _) = DateTimeAtomType

3641atomTypeForAtom (ByteStringAtom _) = ByteStringAtomType

3742atomTypeForAtom (BoolAtom _) = BoolAtomType

38−atomTypeForAtom (IntervalAtom a _ _ _) = IntervalAtomType (atomTypeForAtom a)

3943atomTypeForAtom (RelationAtom (Relation attrs _)) = RelationAtomType attrs

4044atomTypeForAtom (ConstructedAtom _ aType _) = aType

src/lib/ProjectM36/DatabaseContextFunction.hs+20−1

@@ -2,8 +2,13 @@ module ProjectM36.DatabaseContextFunction where

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

33import ProjectM36.Base

44import ProjectM36.Error

5+import ProjectM36.Attribute as A

6+import ProjectM36.Relation

7+import ProjectM36.AtomType

58import qualified Data.HashSet as HS

69import qualified Data.Map as M

10+import ProjectM36.ScriptSession

11+import qualified Data.Text as T

712

813emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction

914emptyDatabaseContextFunction name = DatabaseContextFunction {

@@ -53,4 +58,18 @@ databaseContextFunctionReturnType tCons = ADTypeConstructor "Either" [

5358 tCons]

5459

5560createScriptedDatabaseContextFunction :: DatabaseContextFunctionName -> [TypeConstructor] -> TypeConstructor -> DatabaseContextFunctionBodyScript -> DatabaseContextIOExpr

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

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

62+

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

64+loadDatabaseContextFunctions = loadFunction

65+

66+databaseContextFunctionsAsRelation :: DatabaseContextFunctions -> Either RelationalError Relation

67+databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups

68+ where

69+ attrs = A.attributesFromList [Attribute "name" TextAtomType,

70+ Attribute "arguments" TextAtomType]

71+ tups = map dbcFuncToTuple (HS.toList dbcFuncs)

72+ dbcFuncToTuple func = [TextAtom (dbcFuncName func),

73+ TextAtom (dbcTextType (dbcFuncType func))]

74+ dbcTextType typ = T.intercalate " -> " (map prettyAtomType typ ++ ["DatabaseContext", "DatabaseContext"])

75+

src/lib/ProjectM36/Error.hs+1

@@ -85,6 +85,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

8585 | UnhandledExceptionError String

8686 | MergeTransactionError MergeError

8787 | ScriptError ScriptCompilationError

88+ | LoadFunctionError

8889 | DatabaseContextFunctionUserError DatabaseContextFunctionError

8990 | DatabaseLoadError PersistenceError

9091

src/lib/ProjectM36/Persist.hs+3−2

@@ -6,7 +6,6 @@ module ProjectM36.Persist (writeFileSync,

66 printFdCount,

77 DiskSync(..)) where

88-- on Windows, use FlushFileBuffers and MoveFileEx

9−import qualified Data.Text.IO as TIO

109import qualified Data.Text as T

1110

1211#if defined(linux_HOST_OS)

@@ -38,6 +37,8 @@ import Foreign.C

3837

3938import System.IO (withFile, IOMode(WriteMode), Handle)

4039import qualified Data.ByteString.Lazy as BS

40+import qualified Data.ByteString as BS'

41+import qualified Data.Text.Encoding as TE

4142

4243#if defined(mingw32_HOST_OS)

4344import ProjectM36.Win32Handle

@@ -52,7 +53,7 @@ writeFileSync :: DiskSync -> FilePath -> T.Text -> IO()

5253writeFileSync sync path strOut = withFile path WriteMode handler

5354 where

5455 handler handle = do

55− TIO.hPutStr handle strOut

56+ BS'.hPut handle (TE.encodeUtf8 strOut)

5657 syncHandle sync handle

5758

5859renameSync :: DiskSync -> FilePath -> FilePath -> IO ()

src/lib/ProjectM36/Relation.hs+6−4

@@ -317,11 +317,13 @@ relationVariablesAsRelation relVarMap = mkRelationFromList attrs tups

317317

318318-- | Randomly resort the tuples. This is useful for emphasizing that two relations are equal even when they are printed to the console in different orders.

319319randomizeTupleOrder :: MonadRandom m => Relation -> m Relation

320−randomizeTupleOrder (Relation attrs tupSet) = do

321− newTupSet <- shuffleM (asList tupSet)

322− pure (Relation attrs (RelationTupleSet newTupSet))

320+randomizeTupleOrder (Relation attrs tupSet) =

321+ Relation attrs . RelationTupleSet <$> shuffleM (asList tupSet)

323322

324323-- returns a tuple from the tupleset- this is useful for priming folds over the tuples

325324oneTuple :: Relation -> Maybe RelationTuple

326325oneTuple (Relation _ (RelationTupleSet [])) = Nothing

327−oneTuple (Relation _ (RelationTupleSet (x:_))) = Just x

326+oneTuple (Relation _ (RelationTupleSet (x:_))) = Just x

327+

328+tuplesList :: Relation -> [RelationTuple]

329+tuplesList (Relation _ tupleSet) = asList tupleSet

src/lib/ProjectM36/Relation/Parse/CSV.hs+39−35

@@ -4,6 +4,7 @@ import ProjectM36.Base

44import ProjectM36.Error

55import ProjectM36.Relation

66import ProjectM36.AtomType

7+import ProjectM36.DataTypes.Interval

78import qualified ProjectM36.Attribute as A

89

910import Data.Csv.Parser

@@ -60,9 +61,8 @@ parseCSVAtomP :: AttributeName -> TypeConstructorMapping -> AtomType -> APT.Pars

6061parseCSVAtomP _ _ IntegerAtomType = Right . IntegerAtom <$> APT.decimal

6162parseCSVAtomP _ _ IntAtomType = Right . IntAtom <$> APT.decimal

6263parseCSVAtomP _ _ DoubleAtomType = Right . DoubleAtom <$> APT.double

63−parseCSVAtomP _ _ TextAtomType = do

64− s <- quotedString <|> takeToEndOfData

65− pure (Right (TextAtom s))

64+parseCSVAtomP _ _ TextAtomType =

65+ Right . TextAtom <$> (quotedString <|> takeToEndOfData)

6666parseCSVAtomP _ _ DayAtomType = do

6767 dString <- T.unpack <$> takeToEndOfData

6868 case readMaybe dString of

@@ -83,41 +83,45 @@ parseCSVAtomP _ _ BoolAtomType = do

8383 case readMaybe bString of

8484 Nothing -> fail ("invalid BoolAtom string: " ++ bString)

8585 Just b -> pure (Right (BoolAtom b))

86−parseCSVAtomP attrName tConsMap (IntervalAtomType iType) = do

87− begin <- (APT.char '[' >> pure False) <|> (APT.char '(' >> pure True)

88− eBeginv <- parseCSVAtomP attrName tConsMap iType

89− case eBeginv of

90− Left err -> pure (Left err)

91− Right beginv -> do

92− _ <- APT.char ','

93− eEndv <- parseCSVAtomP attrName tConsMap iType

94− case eEndv of

95− Left err -> pure (Left err)

96− Right endv -> do

97− end <- (APT.char ']' >> pure False) <|> (APT.char ')' >> pure True)

98− pure (Right (IntervalAtom beginv endv begin end))

99−parseCSVAtomP attrName tConsMap typ@(ConstructedAtomType _ tvmap) = do

100− dConsName <- capitalizedIdentifier

101− APT.skipSpace

86+parseCSVAtomP attrName tConsMap typ@(ConstructedAtomType _ tvmap)

87+ | isIntervalAtomType typ = do

88+ begin <- (APT.char '[' >> pure False) <|> (APT.char '(' >> pure True)

89+ let iType = intervalSubType typ

90+ eBeginv <- parseCSVAtomP attrName tConsMap iType

91+ case eBeginv of

92+ Left err -> pure (Left err)

93+ Right beginv -> do

94+ _ <- APT.char ','

95+ eEndv <- parseCSVAtomP attrName tConsMap iType

96+ case eEndv of

97+ Left err -> pure (Left err)

98+ Right endv -> do

99+ end <- (APT.char ']' >> pure False) <|>

100+ (APT.char ')' >> pure True)

101+ pure (Right (ConstructedAtom "Interval" typ [beginv, endv,

102+ BoolAtom begin, BoolAtom end]))

103+ | otherwise = do

104+ dConsName <- capitalizedIdentifier

105+ APT.skipSpace

102106 --we need to look up the name right away in order to determine the types of the following arguments

103107 -- grab the data constructor

104− case findDataConstructor dConsName tConsMap of

105− Nothing -> pure (Left (NoSuchDataConstructorError dConsName))

106− Just (_, dConsDef) ->

108+ case findDataConstructor dConsName tConsMap of

109+ Nothing -> pure (Left (NoSuchDataConstructorError dConsName))

110+ Just (_, dConsDef) ->

107111 -- identify the data constructor's expected atom type args

108− case resolvedAtomTypesForDataConstructorDefArgs tConsMap tvmap dConsDef of

109− Left err -> pure (Left err)

110− Right argAtomTypes -> do

111− atomArgs <- mapM (\argTyp -> let parseNextAtom = parseCSVAtomP attrName tConsMap argTyp <* APT.skipSpace in

112− case argTyp of

113− ConstructedAtomType _ _ ->

114− parens parseNextAtom <|>

115− parseNextAtom

116− _ -> parseNextAtom

117− ) argAtomTypes

118− case lefts atomArgs of

119− [] -> pure (Right (ConstructedAtom dConsName typ (rights atomArgs)))

120− errs -> pure (Left (someErrors errs))

112+ case resolvedAtomTypesForDataConstructorDefArgs tConsMap tvmap dConsDef of

113+ Left err -> pure (Left err)

114+ Right argAtomTypes -> do

115+ atomArgs <- mapM (\argTyp -> let parseNextAtom = parseCSVAtomP attrName tConsMap argTyp <* APT.skipSpace in

116+ case argTyp of

117+ ConstructedAtomType _ _ ->

118+ parens parseNextAtom <|>

119+ parseNextAtom

120+ _ -> parseNextAtom

121+ ) argAtomTypes

122+ case lefts atomArgs of

123+ [] -> pure (Right (ConstructedAtom dConsName typ (rights atomArgs)))

124+ errs -> pure (Left (someErrors errs))

121125parseCSVAtomP attrName _ (RelationAtomType _) = pure (Left (RelationValuedAttributesNotSupportedError [attrName]))

122126parseCSVAtomP _ _ (TypeVariableType x) = pure (Left (TypeConstructorTypeVarMissing x))

123127

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

@@ -41,7 +41,7 @@ instance DefaultOrdered RecordRelationTuple where

4141newtype RecordAtom = RecordAtom {unAtom :: Atom}

4242

4343instance ToField RecordAtom where

44− toField (RecordAtom (TextAtom atomVal)) = TE.encodeUtf8 atomVal --squelch extraneous quotes for text type- the CSV library will add them if necessary

44+ toField (RecordAtom (TextAtom atomVal)) = TE.encodeUtf8 atomVal --without this, CSV text atoms are doubly quoted

4545 toField (RecordAtom atomVal) = (TE.encodeUtf8 . atomToText) atomVal

4646

4747

src/lib/ProjectM36/Relation/Show/Term.hs+17−2

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

99import qualified Data.List as L

1010import qualified Data.Text as T

1111import Control.Arrow hiding (left)

12+import Data.Monoid

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

1214

1315boxV :: StringType

1416boxV = "│"

@@ -77,7 +79,7 @@ cellSizes (header, body) = map (map maxRowWidth &&& map (length . breakLines)) a

7779 0

7880 else

7981 L.maximum (lengths row)

80− lengths row = map T.length (breakLines row)

82+ lengths row = map stringDisplayLength (breakLines row)

8183 allRows = header : body

8284

8385relationAsTable :: Relation -> Table

@@ -102,6 +104,7 @@ showParens predicate f = if predicate then

102104showAtom :: Int -> Atom -> StringType

103105showAtom _ (RelationAtom rel) = renderTable $ relationAsTable rel

104106showAtom level (ConstructedAtom dConsName _ atoms) = showParens (level >= 1 && not (null atoms)) $ T.concat (L.intersperse " " (dConsName : map (showAtom 1) atoms))

107+showAtom _ (TextAtom t) = "\"" <> t <> "\""

105108showAtom _ atom = atomToText atom

106109

107110renderTable :: Table -> StringType

@@ -120,13 +123,14 @@ renderHeader (header, body) columnLocations = renderTopBar `T.append` renderHead

120123renderHBar :: StringType -> StringType -> StringType -> [Int] -> StringType

121124renderHBar left middle end columnLocations = left `T.append` T.concat (L.intersperse middle (map (`repeatString` boxH) columnLocations)) `T.append` end

122125

126+--pad a block of potentially multi-lined text

123127leftPaddedString :: Int -> Int -> StringType -> StringType

124128leftPaddedString lineNum size str = if lineNum > length paddedLines -1 then

125129 repeatString size " "

126130 else

127131 paddedLines !! lineNum

128132 where

129− paddedLines = map (\line -> line `T.append` repeatString (size - T.length line) " ") (breakLines str)

133+ paddedLines = map (\line -> line `T.append` repeatString (size - stringDisplayLength line) " ") (breakLines str)

130134

131135renderRow :: [Cell] -> [Int] -> Int -> StringType -> StringType

132136renderRow cells columnLocations rowHeight interspersed = T.unlines $ map renderOneLine [0..rowHeight-1]

@@ -147,3 +151,14 @@ repeatString c s = T.concat (replicate c s)

147151

148152showRelation :: Relation -> StringType

149153showRelation rel = renderTable (relationAsTable rel)

154+

155+--use wcwidth to guess the string width in the terminal- many CJK characters can take multiple columns in a fixed width font

156+stringDisplayLength :: StringType -> Int

157+stringDisplayLength = T.foldr charSize 0

158+ where

159+ charSize char accum = let w = wcwidth char in

160+ accum + if w < 0 then

161+ 1

162+ else

163+ w

164+

src/lib/ProjectM36/RelationalExpression.hs+92−30

@@ -11,6 +11,7 @@ import ProjectM36.ScriptSession

1111import ProjectM36.DataTypes.Primitive

1212import ProjectM36.AtomFunction

1313import ProjectM36.DatabaseContextFunction

14+import ProjectM36.Arbitrary

1415import qualified ProjectM36.Attribute as A

1516import qualified Data.Map as M

1617import qualified Data.HashSet as HS

@@ -25,7 +26,7 @@ import qualified Data.Vector as V

2526import qualified ProjectM36.TypeConstructorDef as TCD

2627import Control.Monad.Trans.Except

2728import Control.Monad.Trans.Reader

28−

29+import Test.QuickCheck

2930import GHC

3031import GHC.Paths

3132

@@ -161,9 +162,8 @@ evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

161162 -- if the mAttrExprs is Nothing, then we should attempt to infer the tuple attributes from the first tuple itself- note that this is not always possible

162163 runExceptT $ do

163164 mAttrs <- case mAttrExprs of

164− Just _ -> do

165− attrs <- mapM (either throwE pure . evalAttrExpr tConss) (fromMaybe [] mAttrExprs)

166− pure (Just (A.attributesFromList attrs))

165+ Just _ ->

166+ Just . A.attributesFromList <$> mapM (either throwE pure . evalAttrExpr tConss) (fromMaybe [] mAttrExprs)

167167 Nothing -> pure Nothing

168168 tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs

169169 let attrs = fromMaybe firstTupleAttrs mAttrs

@@ -214,6 +214,24 @@ evalRelationalExpr (Equals relExprA relExprB) = do

214214 Left err -> return $ Left err

215215 Right relB -> return $ Right $ if relA == relB then relationTrue else relationFalse

216216

217+evalRelationalExpr (With views mainExpr) = do

218+ rstate <- ask

219+

220+ let addScopedView ctx (vname,vexpr) = if vname `M.member` relationVariables ctx then

221+ Left (RelVarAlreadyDefinedError vname)

222+ else

223+ case runState (evalDatabaseContextExpr (Assign vname vexpr)) (freshDatabaseState ctx) of

224+ (Left err,_) -> Left err

225+ (Right (), (ctx',_,_)) -> Right ctx'

226+

227+ case foldM addScopedView (stateElemsContext rstate) views of

228+ Left err -> return $ Left err

229+ Right ctx'' -> do

230+ let evalMainExpr expr = runReader (evalRelationalExpr expr) (RelationalExprStateElems ctx'')

231+ case evalMainExpr mainExpr of

232+ Left err -> return $ Left err

233+ Right rel -> return $ Right rel

234+

217235--warning: copy-pasta from above- refactor

218236evalRelationalExpr (NotEquals relExprA relExprB) = do

219237 evaldA <- evalRelationalExpr relExprA

@@ -269,14 +287,21 @@ evalDatabaseContextExpr (Define relVarName attrExprs) = do

269287 relvars <- fmap relationVariables getStateContext

270288 tConss <- fmap typeConstructorMapping getStateContext

271289 let eAttrs = map (evalAttrExpr tConss) attrExprs

272− case lefts eAttrs of

273− err:_ -> pure (Left err)

274− [] -> case M.member relVarName relvars of

275− True -> pure (Left (RelVarAlreadyDefinedError relVarName))

276− False -> setRelVar relVarName emptyRelation >> pure (Right ())

277− where

278− attrs = A.attributesFromList (rights eAttrs)

279− emptyRelation = Relation attrs emptyTupleSet

290+ attrErrs = lefts eAttrs

291+ attrsList = rights eAttrs

292+ if not (null attrErrs) then

293+ pure (Left (someErrors attrErrs))

294+ else do

295+ let atomTypeErrs = lefts $ map ((`validateAtomType` tConss) . A.atomType) attrsList

296+ if not (null atomTypeErrs) then

297+ pure (Left (someErrors atomTypeErrs))

298+ else

299+ case M.member relVarName relvars of

300+ True -> pure (Left (RelVarAlreadyDefinedError relVarName))

301+ False -> setRelVar relVarName emptyRelation >> pure (Right ())

302+ where

303+ attrs = A.attributesFromList attrsList

304+ emptyRelation = Relation attrs emptyTupleSet

280305

281306evalDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName

282307

@@ -506,7 +531,7 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcNam

506531 pure $ case eCompiledFunc of

507532 Left err -> Left (ScriptError err)

508533 Right compiledFunc -> do

509− funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext) M.empty) adjustedAtomTypeCons

534+ funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructorValidate False funcTypeArg (typeConstructorMapping currentContext) M.empty) adjustedAtomTypeCons

510535 let updatedFuncs = HS.insert newAtomFunc atomFuncs

511536 newContext = currentContext { atomFunctions = updatedFuncs }

512537 newAtomFunc = AtomFunction { atomFuncName = funcName,

@@ -562,8 +587,42 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunct

562587 Right eContext -> case eContext of

563588 Left err -> pure (Left err)

564589 Right context' -> pure (Right context')

565−

566−

590+evalDatabaseContextIOExpr _ currentContext (LoadAtomFunctions modName funcName modPath) = do

591+ eLoadFunc <- loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath

592+ case eLoadFunc of

593+ Left LoadSymbolError -> pure (Left LoadFunctionError)

594+ Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }

595+ mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)

596+ in pure (Right newContext)

597+evalDatabaseContextIOExpr _ currentContext (LoadDatabaseContextFunctions modName funcName modPath) = do

598+ eLoadFunc <- loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath

599+ case eLoadFunc of

600+ Left LoadSymbolError -> pure (Left LoadFunctionError)

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

602+ mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)

603+ in pure (Right newContext)

604+

605+evalDatabaseContextIOExpr _ currentContext (CreateArbitraryRelation relVarName attrExprs range) =

606+ --Define

607+ case runState ( evalDatabaseContextExpr (Define relVarName attrExprs)) (freshDatabaseState currentContext) of

608+ (Left err,_) -> pure (Left err)

609+ (Right (), elems@(ctx,_,_)) -> do

610+ --Assign

611+ let existingRelVar = M.lookup relVarName relVarTable

612+ relVarTable = relationVariables ctx

613+ case existingRelVar of

614+ Nothing -> pure $ Left (RelVarNotDefinedError relVarName)

615+ Just existingRel -> do

616+ let expectedAttributes = attributes existingRel

617+ let tcMap = typeConstructorMapping ctx

618+ eitherRel <- generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap

619+ case eitherRel of

620+ Left err -> pure $ Left err

621+ Right rel ->

622+ case runState (setRelVar relVarName rel) elems of

623+ (Left err,_) -> pure (Left err)

624+ (Right (), (ctx',_,_)) -> pure $ Right ctx'

625+

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

568627updateTupleWithAtomExprs exprMap context tupIn = do

569628 --resolve all atom exprs

@@ -575,9 +634,8 @@ updateTupleWithAtomExprs exprMap context tupIn = do

575634

576635--run verification on all constraints

577636checkConstraints :: DatabaseContext -> Either RelationalError ()

578−checkConstraints context = do

637+checkConstraints context =

579638 mapM_ (uncurry checkIncDep) (M.toList deps)

580− pure ()

581639 where

582640 deps = inclusionDependencies context

583641 eval expr = evalReader (evalRelationalExpr expr)

@@ -646,9 +704,7 @@ predicateRestrictionFilter _ TruePredicate = pure (Right (\_ -> pure True))

646704predicateRestrictionFilter attrs (NotPredicate expr) =

647705 runExceptT $ do

648706 exprv <- liftE (predicateRestrictionFilter attrs expr)

649− pure (\x -> do

650− ev <- exprv x

651− pure (not ev))

707+ pure (fmap not . exprv)

652708

653709--optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here

654710predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do

@@ -811,10 +867,9 @@ typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do

811867-- grab the type of the data constructor, then validate that the args match the expected types

812868typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =

813869 runExceptT $ do

814− argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs

870+ argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs

815871 context <- fmap stateElemsContext (lift ask)

816− aType <- either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)

817− pure aType

872+ either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)

818873

819874-- | Validate that the type of the AtomExpr matches the expected type.

820875verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType)

@@ -857,30 +912,38 @@ verifyAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = runExceptT $ d

857912-- | Look up the type's name and create a new attribute.

858913evalAttrExpr :: TypeConstructorMapping -> AttributeExpr -> Either RelationalError Attribute

859914evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tCons ()) = do

860− aType <- atomTypeForTypeConstructor tCons aTypes M.empty

915+ aType <- atomTypeForTypeConstructorValidate True tCons aTypes M.empty

916+ validateAtomType aType aTypes

861917 Right (Attribute attrName aType)

862918

863919evalAttrExpr _ (NakedAttributeExpr attr) = Right attr

864920

865921evalTupleExpr :: Maybe Attributes -> TupleExpr -> RelationalExprState (Either RelationalError RelationTuple)

866−evalTupleExpr attrs (TupleExpr tupMap) = do

922+evalTupleExpr mAttrs (TupleExpr tupMap) = do

867923 context <- fmap stateElemsContext ask

868924 runExceptT $ do

869925 -- it's not possible for AtomExprs in tuple constructors to reference other Attributes' atoms due to the necessary order-of-operations (need a tuple to pass to evalAtomExpr)- it may be possible with some refactoring of type usage or delayed evaluation- needs more thought, but not a priority

870926 -- I could adjust this logic so that when the attributes are not specified (Nothing), then I can attempt to extract the attributes from the tuple- the type resolution will blow up if an ambiguous data constructor is used (Left 4) and this should allow simple cases to "relation{tuple{a 4}}" to be processed

927+ let attrs = fromMaybe A.emptyAttributes mAttrs

871928 attrAtoms <- mapM (\(attrName, aExpr) -> do

872− newAtomType <- liftE (typeFromAtomExpr A.emptyAttributes aExpr)

929+ --provided when the relation header is available

930+ let eExpectedAtomType = A.atomTypeForAttributeName attrName attrs

931+ unresolvedType <- liftE (typeFromAtomExpr attrs aExpr)

932+ resolvedType <- case eExpectedAtomType of

933+ Left _ -> pure unresolvedType

934+ Right typeHint -> either throwE pure (resolveAtomType typeHint unresolvedType)

935+ --resolve atom typevars based on resolvedType?

873936 newAtom <- liftE (evalAtomExpr emptyTuple aExpr)

874− pure (attrName, newAtom, newAtomType)

937+ pure (attrName, newAtom, resolvedType)

875938 ) (M.toList tupMap)

876939 let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms

877940 atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms

878941 tup = mkRelationTuple tupAttrs atoms

879942 tConss = typeConstructorMapping context

880− finalAttrs = fromMaybe tupAttrs attrs

943+ finalAttrs = fromMaybe tupAttrs mAttrs

881944 --verify that the attributes match

882945 when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwE (TupleAttributeTypeMismatchError tupAttrs)

883− tup' <- either throwE pure (resolveTypesInTuple finalAttrs (reorderTuple finalAttrs tup))

946+ tup' <- either throwE pure (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup))

884947 _ <- either throwE pure (validateTuple tup' tConss)

885948 pure tup'

886949

@@ -932,4 +995,3 @@ evalAttributeNames attrNames expr = do

932995 Left err -> pure (Left err)

933996 Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))

934997

935−

src/lib/ProjectM36/ScriptSession.hs+46−3

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

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

12module ProjectM36.ScriptSession where

23

34import ProjectM36.Error

@@ -9,6 +10,7 @@ import System.Directory

910import Control.Monad.IO.Class

1011import System.FilePath.Glob

1112import System.FilePath

13+import System.Info (os, arch)

1214import Data.Text (Text, unpack)

1315import Data.Maybe

1416

@@ -16,6 +18,9 @@ import GHC

1618import GHC.Paths (libdir)

1719#if __GLASGOW_HASKELL__ >= 800

1820import GHC.LanguageExtensions

21+import GHCi.ObjLink

22+#else

23+import ObjLink

1924#endif

2025#if __GLASGOW_HASKELL__ >= 802

2126import BasicTypes

@@ -32,6 +37,10 @@ import Type hiding (pprTyThing)

3237#else

3338#endif

3439

40+import GHC.Exts (addrToAny#)

41+import GHC.Ptr (Ptr(..))

42+import Encoding

43+

3544data ScriptSession = ScriptSession {

3645 hscEnv :: HscEnv,

3746 atomFunctionBodyType :: Type,

@@ -180,12 +189,11 @@ compileScript funcType script = do

180189 mErr <- typeCheckScript funcType script

181190 case mErr of

182191 Just err -> pure (Left err)

183− Nothing -> do

192+ Nothing ->

184193 --catch exception here

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

186195 -- we can't use dynCompileExpr here because

187− func <- compileExpr sScript

188− pure $ Right (unsafeCoerce func)

196+ Right . unsafeCoerce <$> compileExpr sScript

189197

190198typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError)

191199typeCheckScript expectedType inp = do

@@ -201,4 +209,39 @@ typeCheckScript expectedType inp = do

201209 pure Nothing

202210 else

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

212+

213+mangleSymbol :: Maybe String -> String -> String -> String

214+mangleSymbol pkg module' valsym =

215+ prefixUnderscore ++

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

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

218+

219+type ModName = String

220+type FuncName = String

221+

222+data LoadSymbolError = LoadSymbolError

223+

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

225+loadFunction modName funcName objPath = do

226+#if __GLASGOW_HASKELL__ >= 802

227+ initObjLinker RetainCAFs

228+#else

229+ initObjLinker

230+#endif

231+ loadObj objPath

232+ _ <- resolveObjs

233+ ptr <- lookupSymbol (mangleSymbol Nothing modName funcName)

234+ case ptr of

235+ Nothing -> pure (Left LoadSymbolError)

236+ Just (Ptr addr) -> case addrToAny# addr of

237+ (# hval #) -> pure (Right hval)

204238

239+prefixUnderscore :: String

240+prefixUnderscore =

241+ case (os,arch) of

242+ ("mingw32","x86_64") -> ""

243+ ("cygwin","x86_64") -> ""

244+ ("mingw32",_) -> "_"

245+ ("darwin",_) -> "_"

246+ ("cygwin",_) -> "_"

247+ _ -> ""

src/lib/ProjectM36/Server.hs+36−25

@@ -41,6 +41,8 @@ serverDefinition testBool ti = defaultProcess {

4141 handleCall (\conn (CloseSession sessionId) -> handleCloseSession ti sessionId conn),

4242 handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation ti sessionId conn),

4343 handleCall (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary ti sessionId conn),

44+ handleCall (\conn (RetrieveAtomFunctionSummary sessionId) -> handleRetrieveAtomFunctionSummary ti sessionId conn),

45+ handleCall (\conn (RetrieveDatabaseContextFunctionSummary sessionId) -> handleRetrieveDatabaseContextFunctionSummary ti sessionId conn),

4446 handleCall (\conn (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName ti sessionId conn),

4547 handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr),

4648 handleCall (\conn (RetrieveSessionIsDirty sessionId) -> handleRetrieveSessionIsDirty ti sessionId conn),

@@ -100,28 +102,37 @@ checkFSErrorMsg = "The filesystem does not support journaling so writes may not

100102

101103-- | A synchronous function to start the project-m36 daemon given an appropriate 'ServerConfig'. Note that this function only returns if the server exits. Returns False if the daemon exited due to an error. If the second argument is not Nothing, the port is put after the server is ready to service the port.

102104launchServer :: ServerConfig -> Maybe (MVar EndPointAddress) -> IO Bool

103−launchServer daemonConfig mAddressMVar = do

104− econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback (ghcPkgPaths daemonConfig))

105− case econn of

106− Left err -> do

107− hPutStrLn stderr ("Failed to create database connection: " ++ show err)

108− pure False

109− Right conn -> do

110− let hostname = bindHost daemonConfig

111− port = bindPort daemonConfig

112− etransport <- createTransport hostname (show port) (\sn -> (hostname, sn)) defaultTCPParameters

113− case etransport of

114− Left err -> error ("failed to create transport: " ++ show err)

115− Right transport -> do

116− eEndpoint <- newEndPoint transport

117− case eEndpoint of

118− Left err -> hPutStrLn stderr ("Failed to create transport: " ++ show err) >> pure False

119− Right endpoint -> do

120− localTCPNode <- newLocalNode transport initRemoteTable

121− --traceShowM ("newLocalNode in Server " ++ show (localNodeId localTCPNode))

122− runProcess localTCPNode $ do

123− let testBool = testMode daemonConfig

124− reqTimeout = perRequestTimeout daemonConfig

125− serve (conn, databaseName daemonConfig, mAddressMVar, address endpoint) initServer (serverDefinition testBool reqTimeout)

126− liftIO $ putStrLn "serve returned"

127− pure True

105+launchServer daemonConfig mAddressMVar = do

106+ checkFSResult <- checkFSType (checkFS daemonConfig) (persistenceStrategy daemonConfig)

107+ if not checkFSResult then do

108+ hPutStrLn stderr checkFSErrorMsg

109+ pure False

110+ else do

111+ econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback (ghcPkgPaths daemonConfig))

112+ case econn of

113+ Left err -> do

114+ hPutStrLn stderr ("Failed to create database connection: " ++ show err)

115+ pure False

116+ Right conn -> do

117+ let hostname = bindHost daemonConfig

118+ port = bindPort daemonConfig

119+#if MIN_VERSION_network_transport_tcp(0,6,0)

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

121+#else

122+ etransport <- createTransport hostname (show port) defaultTCPParameters

123+#endif

124+ case etransport of

125+ Left err -> error ("failed to create transport: " ++ show err)

126+ Right transport -> do

127+ eEndpoint <- newEndPoint transport

128+ case eEndpoint of

129+ Left err -> hPutStrLn stderr ("Failed to create transport: " ++ show err) >> pure False

130+ Right endpoint -> do

131+ localTCPNode <- newLocalNode transport initRemoteTable

132+ --traceShowM ("newLocalNode in Server " ++ show (localNodeId localTCPNode))

133+ runProcess localTCPNode $ do

134+ let testBool = testMode daemonConfig

135+ reqTimeout = perRequestTimeout daemonConfig

136+ serve (conn, databaseName daemonConfig, mAddressMVar, address endpoint) initServer (serverDefinition testBool reqTimeout)

137+ liftIO $ putStrLn "serve returned"

138+ pure True

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

@@ -120,6 +120,16 @@ handleRetrieveRelationVariableSummary ti sessionId conn = do

120120 ret <- timeoutOrDie ti (relationVariablesAsRelation sessionId conn)

121121 reply ret conn

122122

123+handleRetrieveAtomFunctionSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)

124+handleRetrieveAtomFunctionSummary ti sessionId conn = do

125+ ret <- timeoutOrDie ti (atomFunctionsAsRelation sessionId conn)

126+ reply ret conn

127+

128+handleRetrieveDatabaseContextFunctionSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)

129+handleRetrieveDatabaseContextFunctionSummary ti sessionId conn = do

130+ ret <- timeoutOrDie ti (databaseContextFunctionsAsRelation sessionId conn)

131+ reply ret conn

132+

123133handleRetrieveCurrentSchemaName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError SchemaName)

124134handleRetrieveCurrentSchemaName ti sessionId conn = do

125135 ret <- timeoutOrDie ti (currentSchemaName sessionId conn)

src/lib/ProjectM36/Server/RemoteCallTypes.hs+4

@@ -52,6 +52,10 @@ data RetrieveAtomTypesAsRelation = RetrieveAtomTypesAsRelation SessionId

5252 deriving (Binary, Generic)

5353data RetrieveRelationVariableSummary = RetrieveRelationVariableSummary SessionId

5454 deriving (Binary, Generic)

55+data RetrieveAtomFunctionSummary = RetrieveAtomFunctionSummary SessionId

56+ deriving (Binary, Generic)

57+data RetrieveDatabaseContextFunctionSummary = RetrieveDatabaseContextFunctionSummary SessionId

58+ deriving (Binary, Generic)

5559data RetrieveCurrentSchemaName = RetrieveCurrentSchemaName SessionId

5660 deriving (Binary, Generic)

5761data TestTimeout = TestTimeout SessionId

src/lib/ProjectM36/Sessions.hs+11−4

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

11{-# LANGUAGE PackageImports #-}

22module ProjectM36.Sessions where

33import Control.Concurrent.STM

4−import qualified STMContainers.Map as STMMap

4+import qualified StmContainers.Map as StmMap

5+import qualified StmContainers.Set as StmSet

56import "list-t" ListT

67import ProjectM36.Attribute

78import ProjectM36.Base

@@ -9,11 +10,17 @@ import ProjectM36.Session

910import ProjectM36.Relation

1011import ProjectM36.Error

1112import qualified Data.UUID as U

13+import qualified Control.Foldl as Foldl

14+import qualified DeferredFolds.UnfoldM as UnfoldM

1215

13−type Sessions = STMMap.Map SessionId Session

16+type Sessions = StmMap.Map SessionId Session

1417

15−stmMapToList :: STMMap.Map k v -> STM [(k, v)]

16−stmMapToList = ListT.fold (\l -> return . (:l)) [] . STMMap.stream

18+--from https://github.com/nikita-volkov/stm-containers/blob/master/test/Main/MapTests.hs

19+stmMapToList :: StmMap.Map k v -> STM [(k, v)]

20+stmMapToList = UnfoldM.foldM (Foldl.generalize Foldl.list) . StmMap.unfoldM

21+

22+stmSetToList :: StmSet.Set v -> STM [v]

23+stmSetToList = UnfoldM.foldM (Foldl.generalize Foldl.list) . StmSet.unfoldM

1724

1825uuidAtom :: U.UUID -> Atom

1926uuidAtom = TextAtom . U.toText

src/lib/ProjectM36/StaticOptimizer.hs+5−1

@@ -134,6 +134,8 @@ applyStaticRelationalOptimization e@(NotEquals _ _) = pure $ Right e

134134

135135applyStaticRelationalOptimization e@(Extend _ _) = pure $ Right e

136136

137+applyStaticRelationalOptimization e@(With _ _) = pure $ Right e

138+

137139applyStaticDatabaseOptimization :: DatabaseContextExpr -> DatabaseState (Either RelationalError DatabaseContextExpr)

138140applyStaticDatabaseOptimization x@NoOperation = pure $ Right x

139141applyStaticDatabaseOptimization x@(Define _ _) = pure $ Right x

@@ -378,6 +380,7 @@ applyStaticRestrictionCollapse expr =

378380 MakeStaticRelation _ _ -> expr

379381 ExistingRelation _ -> expr

380382 RelationVariable _ _ -> expr

383+ With _ _ -> expr

381384 Project attrs subexpr ->

382385 Project attrs (applyStaticRestrictionCollapse subexpr)

383386 Union sub1 sub2 ->

@@ -420,6 +423,7 @@ applyStaticRestrictionPushdown expr = case expr of

420423 MakeStaticRelation _ _ -> expr

421424 ExistingRelation _ -> expr

422425 RelationVariable _ _ -> expr

426+ With _ _ -> expr

423427 Project _ _ -> expr

424428 --this transformation cannot be inverted because the projection attributes might not exist in the inverted version

425429 Restrict restrictAttrs (Project projAttrs subexpr) ->

@@ -450,4 +454,4 @@ applyStaticRestrictionPushdown expr = case expr of

450454 Extend n sub ->

451455 Extend n (applyStaticRestrictionPushdown sub)

452456

453−

457+

src/lib/ProjectM36/TransGraphRelationalExpression.hs+25−18

@@ -68,8 +68,8 @@ evalTransGraphRelationalExpr (Join exprA exprB) graph = do

6868 exprB' <- evalTransGraphRelationalExpr exprB graph

6969 pure (Join exprA' exprB')

7070evalTransGraphRelationalExpr (Rename attrName1 attrName2 expr) graph = do

71− expr' <- evalTransGraphRelationalExpr expr graph

72− pure (Rename attrName1 attrName2 expr')

71+ let expr' = evalTransGraphRelationalExpr expr graph

72+ Rename attrName1 attrName2 <$> expr'

7373evalTransGraphRelationalExpr (Difference exprA exprB) graph = do

7474 exprA' <- evalTransGraphRelationalExpr exprA graph

7575 exprB' <- evalTransGraphRelationalExpr exprB graph

@@ -79,8 +79,8 @@ evalTransGraphRelationalExpr (Group transAttrNames attrName expr) graph = do

7979 attrNames <- evalTransAttributeNames transAttrNames graph

8080 pure (Group attrNames attrName expr')

8181evalTransGraphRelationalExpr (Ungroup attrName expr) graph = do

82− expr' <- evalTransGraphRelationalExpr expr graph

83− pure (Ungroup attrName expr')

82+ let expr' = evalTransGraphRelationalExpr expr graph

83+ Ungroup attrName <$> expr'

8484evalTransGraphRelationalExpr (Restrict predicateExpr expr) graph = do

8585 expr' <- evalTransGraphRelationalExpr expr graph

8686 predicateExpr' <- evalTransGraphRestrictionPredicateExpr predicateExpr graph

@@ -97,14 +97,21 @@ evalTransGraphRelationalExpr (Extend extendExpr expr) graph = do

9797 extendExpr' <- evalTransGraphExtendTupleExpr extendExpr graph

9898 expr' <- evalTransGraphRelationalExpr expr graph

9999 pure (Extend extendExpr' expr')

100+evalTransGraphRelationalExpr (With views expr) graph = do

101+ evaldViews <- mapM (\(vname, vexpr) -> do

102+ vexpr' <- evalTransGraphRelationalExpr vexpr graph

103+ pure (vname, vexpr')

104+ ) views

105+ expr' <- evalTransGraphRelationalExpr expr graph

106+ pure (With evaldViews expr')

100107

101108evalTransGraphTupleExpr :: TransactionGraph -> TransGraphTupleExpr -> Either RelationalError TupleExpr

102109evalTransGraphTupleExpr graph (TupleExpr attrMap) = do

103− attrAssoc <- mapM (\(attrName, atomExpr) -> do

110+ let attrAssoc = mapM (\(attrName, atomExpr) -> do

104111 aExpr <- evalTransGraphAtomExpr graph atomExpr

105112 pure (attrName, aExpr)

106113 ) (M.toList attrMap)

107− pure (TupleExpr (M.fromList attrAssoc))

114+ TupleExpr . M.fromList <$> attrAssoc

108115

109116evalTransGraphAtomExpr :: TransactionGraph -> TransGraphAtomExpr -> Either RelationalError AtomExpr

110117evalTransGraphAtomExpr _ (AttributeAtomExpr aname) = pure $ AttributeAtomExpr aname

@@ -116,8 +123,8 @@ evalTransGraphAtomExpr graph (FunctionAtomExpr funcName args tLookup) = do

116123 atom <- runReader (evalAtomExpr emptyTuple (FunctionAtomExpr funcName args' ())) (RelationalExprStateElems (concreteDatabaseContext trans))

117124 pure (NakedAtomExpr atom)

118125evalTransGraphAtomExpr graph (RelationAtomExpr expr) = do

119− expr' <- evalTransGraphRelationalExpr expr graph

120− pure (RelationAtomExpr expr')

126+ let expr' = evalTransGraphRelationalExpr expr graph

127+ RelationAtomExpr <$> expr'

121128evalTransGraphAtomExpr graph (ConstructedAtomExpr dConsName args tLookup) = do

122129 trans <- lookupTransaction graph tLookup

123130 args' <- mapM (evalTransGraphAtomExpr graph) args

@@ -135,22 +142,22 @@ evalTransGraphRestrictionPredicateExpr (OrPredicate exprA exprB) graph = do

135142 exprB' <- evalTransGraphRestrictionPredicateExpr exprB graph

136143 pure (OrPredicate exprA' exprB')

137144evalTransGraphRestrictionPredicateExpr (NotPredicate expr) graph = do

138− expr' <- evalTransGraphRestrictionPredicateExpr expr graph

139− pure (NotPredicate expr')

145+ let expr' = evalTransGraphRestrictionPredicateExpr expr graph

146+ NotPredicate <$> expr'

140147evalTransGraphRestrictionPredicateExpr (RelationalExprPredicate expr) graph = do

141− expr' <- evalTransGraphRelationalExpr expr graph

142− pure (RelationalExprPredicate expr')

148+ let expr' = evalTransGraphRelationalExpr expr graph

149+ RelationalExprPredicate <$> expr'

143150evalTransGraphRestrictionPredicateExpr (AtomExprPredicate expr) graph = do

144− expr' <- evalTransGraphAtomExpr graph expr

145− pure (AtomExprPredicate expr')

151+ let expr' = evalTransGraphAtomExpr graph expr

152+ AtomExprPredicate <$> expr'

146153evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr) graph = do

147− expr' <- evalTransGraphAtomExpr graph expr

148− pure (AttributeEqualityPredicate attrName expr')

154+ let expr' = evalTransGraphAtomExpr graph expr

155+ AttributeEqualityPredicate attrName <$> expr'

149156

150157evalTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransactionGraph -> Either RelationalError ExtendTupleExpr

151158evalTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) graph = do

152− expr' <- evalTransGraphAtomExpr graph expr

153− pure (AttributeExtendTupleExpr attrName expr')

159+ let expr' = evalTransGraphAtomExpr graph expr

160+ AttributeExtendTupleExpr attrName <$> expr'

154161

155162evalTransGraphAttributeExpr :: TransactionGraph -> TransGraphAttributeExpr -> Either RelationalError AttributeExpr

156163evalTransGraphAttributeExpr graph (AttributeAndTypeNameExpr attrName tCons tLookup) = do

src/lib/ProjectM36/Transaction/Persist.hs−1

@@ -95,7 +95,6 @@ writeTransaction sync dbdir trans = do

9595 B.encodeFile (transactionInfoPath tempTransDir) (transactionInfo trans)

9696 --move the temp directory to final location

9797 renameSync sync tempTransDir finalTransDir

98− pure ()

9998

10099writeRelVar :: DiskSync -> FilePath -> (RelVarName, Relation) -> IO ()

101100writeRelVar sync transDir (relvarName, rel) = do

src/lib/ProjectM36/TransactionGraph.hs+2−2

@@ -321,8 +321,8 @@ evalROGraphOp discon graph ShowGraph = do

321321-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph

322322createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

323323createMergeTransaction stamp newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do

324− selectedTrans <- validateHeadName selectedBranch graph t2

325− pure $ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty stamp) (schemas selectedTrans)

324+ let selectedTrans = validateHeadName selectedBranch graph t2

325+ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty stamp) . schemas <$> selectedTrans

326326

327327-- merge functions, relvars, individually

328328createMergeTransaction stamp newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp newId strat graph t2

src/lib/ProjectM36/TransactionGraph/Persist.hs+17−7

@@ -21,7 +21,8 @@ import Data.Either (isRight)

2121import Data.Maybe (fromMaybe)

2222import qualified Data.List as L

2323import Control.Exception.Base

24−import qualified Data.Text.IO as TIO

24+import qualified Data.ByteString as BS

25+import qualified Data.Text.Encoding as TE

2526import Data.ByteString (ByteString)

2627import Data.Monoid

2728import qualified Crypto.Hash.SHA256 as SHA256

@@ -83,9 +84,8 @@ setupDatabaseDir sync dbdir bootstrapGraph = do

8384 locker <- openLockFile (lockFilePath dbdir)

8485 gDigest <- bracket_ (lockFile locker WriteLock) (unlockFile locker) (readGraphTransactionIdFileDigest dbdir)

8586 pure (Right (locker, gDigest))

86− else if not m36exists then do

87− locks <- bootstrapDatabaseDir sync dbdir bootstrapGraph

88− pure (Right locks)

87+ else if not m36exists then

88+ Right <$> bootstrapDatabaseDir sync dbdir bootstrapGraph

8989 else

9090 pure (Left (InvalidDirectoryError dbdir))

9191{-

@@ -201,8 +201,8 @@ writeGraphTransactionIdFile sync destDirectory (TransactionGraph _ transSet) = w

201201

202202readGraphTransactionIdFileDigest :: FilePath -> IO LockFileHash

203203readGraphTransactionIdFileDigest dbdir = do

204− graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir)

205− pure (SHA256.hash (encodeUtf8 graphTransactionIdData))

204+ let graphTransactionIdData = readUTF8FileOrError (transactionLogPath dbdir)

205+ SHA256.hash . encodeUtf8 <$> graphTransactionIdData

206206

207207readGraphTransactionIdFile :: FilePath -> IO (Either PersistenceError [(TransactionId, UTCTime, [TransactionId])])

208208readGraphTransactionIdFile dbdir = do

@@ -211,5 +211,15 @@ readGraphTransactionIdFile dbdir = do

211211 (readUUID tid, readEpoch epochText, map readUUID parentIds)

212212 readUUID uuidText = fromMaybe (error "failed to read uuid") (U.fromText uuidText)

213213 readEpoch t = posixSecondsToUTCTime (realToFrac (either (error "failed to read epoch") fst (double t)))

214− Right . map grapher . T.lines <$> TIO.readFile (transactionLogPath dbdir)

214+ Right . map grapher . T.lines <$> readUTF8FileOrError (transactionLogPath dbdir)

215215

216+--rationale- reading essential database files must fail hard

217+readUTF8FileOrError :: FilePath -> IO T.Text

218+readUTF8FileOrError pathIn = do

219+ eFileBytes <- try (BS.readFile pathIn) :: IO (Either IOError BS.ByteString)

220+ case eFileBytes of

221+ Left err -> error (show err)

222+ Right fileBytes ->

223+ case TE.decodeUtf8' fileBytes of

224+ Left err -> error (show err)

225+ Right utf8Bytes -> pure utf8Bytes

src/lib/ProjectM36/TypeConstructor.hs+4−6

@@ -1,19 +1,17 @@

11module ProjectM36.TypeConstructor where

22import ProjectM36.Base

3−import qualified Data.Set as S

43

54name :: TypeConstructor -> TypeConstructorName

65name (ADTypeConstructor name' _) = name'

76name (PrimitiveTypeConstructor name' _) = name'

8−name (TypeVariable _) = error "spam" --v --not really the name, but this is used for display only

7+name (RelationAtomTypeConstructor _) = error "name called on RelationAtomTypeConstructor"

8+name (TypeVariable _) = error "name called on TypeVariable" --v --not really the name, but this is used for display only

99

1010arguments :: TypeConstructor -> [TypeConstructor]

1111arguments (ADTypeConstructor _ args) = args

1212arguments (PrimitiveTypeConstructor _ _) = []

13+arguments (RelationAtomTypeConstructor _) = []

1314arguments (TypeVariable _) = []

1415

15−typeVars :: TypeConstructor -> S.Set TypeVarName

16−typeVars (PrimitiveTypeConstructor _ _) = S.empty

17−typeVars (ADTypeConstructor _ args) = S.unions (map typeVars args)

18−typeVars (TypeVariable v) = S.singleton v

16+

1917

src/lib/ProjectM36/WCWidth.hsnew file+425

@@ -0,0 +1,425 @@

1+module ProjectM36.WCWidth where

2+import Data.Set.Range

3+import Data.Char

4+

5+wIDEEASTASIAN :: RangeSet Int

6+wIDEEASTASIAN = foldr insertRange empty [

7+ (0x1100, 0x115f), -- Hangul Choseong Kiyeok ..Hangul Choseong Filler

8+ (0x231a, 0x231b), -- Watch ..Hourglass

9+ (0x2329, 0x232a), -- Left-pointing Angle Brac..Right-pointing Angle Bra

10+ (0x23e9, 0x23ec), -- Black Right-pointing Dou..Black Down-pointing Doub

11+ (0x23f0, 0x23f0), -- Alarm Clock ..Alarm Clock

12+ (0x23f3, 0x23f3), -- Hourglass With Flowing S..Hourglass With Flowing S

13+ (0x25fd, 0x25fe), -- White Medium Small Squar..Black Medium Small Squar

14+ (0x2614, 0x2615), -- Umbrella With Rain Drops..Hot Beverage

15+ (0x2648, 0x2653), -- Aries ..Pisces

16+ (0x267f, 0x267f), -- Wheelchair Symbol ..Wheelchair Symbol

17+ (0x2693, 0x2693), -- Anchor ..Anchor

18+ (0x26a1, 0x26a1), -- High Voltage Sign ..High Voltage Sign

19+ (0x26aa, 0x26ab), -- Medium White Circle ..Medium Black Circle

20+ (0x26bd, 0x26be), -- Soccer Ball ..Baseball

21+ (0x26c4, 0x26c5), -- Snowman Without Snow ..Sun Behind Cloud

22+ (0x26ce, 0x26ce), -- Ophiuchus ..Ophiuchus

23+ (0x26d4, 0x26d4), -- No Entry ..No Entry

24+ (0x26ea, 0x26ea), -- Church ..Church

25+ (0x26f2, 0x26f3), -- Fountain ..Flag In Hole

26+ (0x26f5, 0x26f5), -- Sailboat ..Sailboat

27+ (0x26fa, 0x26fa), -- Tent ..Tent

28+ (0x26fd, 0x26fd), -- Fuel Pump ..Fuel Pump

29+ (0x2705, 0x2705), -- White Heavy Check Mark ..White Heavy Check Mark

30+ (0x270a, 0x270b), -- Raised Fist ..Raised Hand

31+ (0x2728, 0x2728), -- Sparkles ..Sparkles

32+ (0x274c, 0x274c), -- Cross Mark ..Cross Mark

33+ (0x274e, 0x274e), -- Negative Squared Cross M..Negative Squared Cross M

34+ (0x2753, 0x2755), -- Black Question Mark Orna..White Exclamation Mark O

35+ (0x2757, 0x2757), -- Heavy Exclamation Mark S..Heavy Exclamation Mark S

36+ (0x2795, 0x2797), -- Heavy Plus Sign ..Heavy Division Sign

37+ (0x27b0, 0x27b0), -- Curly Loop ..Curly Loop

38+ (0x27bf, 0x27bf), -- Double Curly Loop ..Double Curly Loop

39+ (0x2b1b, 0x2b1c), -- Black Large Square ..White Large Square

40+ (0x2b50, 0x2b50), -- White Medium Star ..White Medium Star

41+ (0x2b55, 0x2b55), -- Heavy Large Circle ..Heavy Large Circle

42+ (0x2e80, 0x2e99), -- Cjk Radical Repeat ..Cjk Radical Rap

43+ (0x2e9b, 0x2ef3), -- Cjk Radical Choke ..Cjk Radical C-simplified

44+ (0x2f00, 0x2fd5), -- Kangxi Radical One ..Kangxi Radical Flute

45+ (0x2ff0, 0x2ffb), -- Ideographic Description ..Ideographic Description

46+ (0x3000, 0x303e), -- Ideographic Space ..Ideographic Variation In

47+ (0x3041, 0x3096), -- Hiragana Letter Small A ..Hiragana Letter Small Ke

48+ (0x3099, 0x30ff), -- Combining Katakana-hirag..Katakana Digraph Koto

49+ (0x3105, 0x312d), -- Bopomofo Letter B ..Bopomofo Letter Ih

50+ (0x3131, 0x318e), -- Hangul Letter Kiyeok ..Hangul Letter Araeae

51+ (0x3190, 0x31ba), -- Ideographic Annotation L..Bopomofo Letter Zy

52+ (0x31c0, 0x31e3), -- Cjk Stroke T ..Cjk Stroke Q

53+ (0x31f0, 0x321e), -- Katakana Letter Small Ku..Parenthesized Korean Cha

54+ (0x3220, 0x3247), -- Parenthesized Ideograph ..Circled Ideograph Koto

55+ (0x3250, 0x32fe), -- Partnership Sign ..Circled Katakana Wo

56+ (0x3300, 0x4dbf), -- Square Apaato ..

57+ (0x4e00, 0xa48c), -- Cjk Unified Ideograph-4e..Yi Syllable Yyr

58+ (0xa490, 0xa4c6), -- Yi Radical Qot ..Yi Radical Ke

59+ (0xa960, 0xa97c), -- Hangul Choseong Tikeut-m..Hangul Choseong Ssangyeo

60+ (0xac00, 0xd7a3), -- Hangul Syllable Ga ..Hangul Syllable Hih

61+ (0xf900, 0xfaff), -- Cjk Compatibility Ideogr..

62+ (0xfe10, 0xfe19), -- Presentation Form For Ve..Presentation Form For Ve

63+ (0xfe30, 0xfe52), -- Presentation Form For Ve..Small Full Stop

64+ (0xfe54, 0xfe66), -- Small Semicolon ..Small Equals Sign

65+ (0xfe68, 0xfe6b), -- Small Reverse Solidus ..Small Commercial At

66+ (0xff01, 0xff60), -- Fullwidth Exclamation Ma..Fullwidth Right White Pa

67+ (0xffe0, 0xffe6), -- Fullwidth Cent Sign ..Fullwidth Won Sign

68+ (0x16fe0, 0x16fe0), -- (nil) ..

69+ (0x17000, 0x187ec), -- (nil) ..

70+ (0x18800, 0x18af2), -- (nil) ..

71+ (0x1b000, 0x1b001), -- Katakana Letter Archaic ..Hiragana Letter Archaic

72+ (0x1f004, 0x1f004), -- Mahjong Tile Red Dragon ..Mahjong Tile Red Dragon

73+ (0x1f0cf, 0x1f0cf), -- Playing Card Black Joker..Playing Card Black Joker

74+ (0x1f18e, 0x1f18e), -- Negative Squared Ab ..Negative Squared Ab

75+ (0x1f191, 0x1f19a), -- Squared Cl ..Squared Vs

76+ (0x1f200, 0x1f202), -- Square Hiragana Hoka ..Squared Katakana Sa

77+ (0x1f210, 0x1f23b), -- Squared Cjk Unified Ideo..

78+ (0x1f240, 0x1f248), -- Tortoise Shell Bracketed..Tortoise Shell Bracketed

79+ (0x1f250, 0x1f251), -- Circled Ideograph Advant..Circled Ideograph Accept

80+ (0x1f300, 0x1f320), -- Cyclone ..Shooting Star

81+ (0x1f32d, 0x1f335), -- Hot Dog ..Cactus

82+ (0x1f337, 0x1f37c), -- Tulip ..Baby Bottle

83+ (0x1f37e, 0x1f393), -- Bottle With Popping Cork..Graduation Cap

84+ (0x1f3a0, 0x1f3ca), -- Carousel Horse ..Swimmer

85+ (0x1f3cf, 0x1f3d3), -- Cricket Bat And Ball ..Table Tennis Paddle And

86+ (0x1f3e0, 0x1f3f0), -- House Building ..European Castle

87+ (0x1f3f4, 0x1f3f4), -- Waving Black Flag ..Waving Black Flag

88+ (0x1f3f8, 0x1f43e), -- Badminton Racquet And Sh..Paw Prints

89+ (0x1f440, 0x1f440), -- Eyes ..Eyes

90+ (0x1f442, 0x1f4fc), -- Ear ..Videocassette

91+ (0x1f4ff, 0x1f53d), -- Prayer Beads ..Down-pointing Small Red

92+ (0x1f54b, 0x1f54e), -- Kaaba ..Menorah With Nine Branch

93+ (0x1f550, 0x1f567), -- Clock Face One Oclock ..Clock Face Twelve-thirty

94+ (0x1f57a, 0x1f57a), -- (nil) ..

95+ (0x1f595, 0x1f596), -- Reversed Hand With Middl..Raised Hand With Part Be

96+ (0x1f5a4, 0x1f5a4), -- (nil) ..

97+ (0x1f5fb, 0x1f64f), -- Mount Fuji ..Person With Folded Hands

98+ (0x1f680, 0x1f6c5), -- Rocket ..Left Luggage

99+ (0x1f6cc, 0x1f6cc), -- Sleeping Accommodation ..Sleeping Accommodation

100+ (0x1f6d0, 0x1f6d2), -- Place Of Worship ..

101+ (0x1f6eb, 0x1f6ec), -- Airplane Departure ..Airplane Arriving

102+ (0x1f6f4, 0x1f6f6), -- (nil) ..

103+ (0x1f910, 0x1f91e), -- Zipper-mouth Face ..

104+ (0x1f920, 0x1f927), -- (nil) ..

105+ (0x1f930, 0x1f930), -- (nil) ..

106+ (0x1f933, 0x1f93e), -- (nil) ..

107+ (0x1f940, 0x1f94b), -- (nil) ..

108+ (0x1f950, 0x1f95e), -- (nil) ..

109+ (0x1f980, 0x1f991), -- Crab ..

110+ (0x1f9c0, 0x1f9c0), -- Cheese Wedge ..Cheese Wedge

111+ (0x20000, 0x2fffd), -- Cjk Unified Ideograph-20..

112+ (0x30000, 0x3fffd) -- (nil) ..

113+ ]

114+

115+zEROWIDTH :: RangeSet Int

116+zEROWIDTH = foldr insertRange empty [

117+ (0x0300, 0x036f), -- Combining Grave Accent ..Combining Latin Small Le

118+ (0x0483, 0x0489), -- Combining Cyrillic Titlo..Combining Cyrillic Milli

119+ (0x0591, 0x05bd), -- Hebrew Accent Etnahta ..Hebrew Point Meteg

120+ (0x05bf, 0x05bf), -- Hebrew Point Rafe ..Hebrew Point Rafe

121+ (0x05c1, 0x05c2), -- Hebrew Point Shin Dot ..Hebrew Point Sin Dot

122+ (0x05c4, 0x05c5), -- Hebrew Mark Upper Dot ..Hebrew Mark Lower Dot

123+ (0x05c7, 0x05c7), -- Hebrew Point Qamats Qata..Hebrew Point Qamats Qata

124+ (0x0610, 0x061a), -- Arabic Sign Sallallahou ..Arabic Small Kasra

125+ (0x064b, 0x065f), -- Arabic Fathatan ..Arabic Wavy Hamza Below

126+ (0x0670, 0x0670), -- Arabic Letter Superscrip..Arabic Letter Superscrip

127+ (0x06d6, 0x06dc), -- Arabic Small High Ligatu..Arabic Small High Seen

128+ (0x06df, 0x06e4), -- Arabic Small High Rounde..Arabic Small High Madda

129+ (0x06e7, 0x06e8), -- Arabic Small High Yeh ..Arabic Small High Noon

130+ (0x06ea, 0x06ed), -- Arabic Empty Centre Low ..Arabic Small Low Meem

131+ (0x0711, 0x0711), -- Syriac Letter Superscrip..Syriac Letter Superscrip

132+ (0x0730, 0x074a), -- Syriac Pthaha Above ..Syriac Barrekh

133+ (0x07a6, 0x07b0), -- Thaana Abafili ..Thaana Sukun

134+ (0x07eb, 0x07f3), -- Nko Combining Short High..Nko Combining Double Dot

135+ (0x0816, 0x0819), -- Samaritan Mark In ..Samaritan Mark Dagesh

136+ (0x081b, 0x0823), -- Samaritan Mark Epentheti..Samaritan Vowel Sign A

137+ (0x0825, 0x0827), -- Samaritan Vowel Sign Sho..Samaritan Vowel Sign U

138+ (0x0829, 0x082d), -- Samaritan Vowel Sign Lon..Samaritan Mark Nequdaa

139+ (0x0859, 0x085b), -- Mandaic Affrication Mark..Mandaic Gemination Mark

140+ (0x08d4, 0x08e1), -- (nil) ..

141+ (0x08e3, 0x0902), -- Arabic Turned Damma Belo..Devanagari Sign Anusvara

142+ (0x093a, 0x093a), -- Devanagari Vowel Sign Oe..Devanagari Vowel Sign Oe

143+ (0x093c, 0x093c), -- Devanagari Sign Nukta ..Devanagari Sign Nukta

144+ (0x0941, 0x0948), -- Devanagari Vowel Sign U ..Devanagari Vowel Sign Ai

145+ (0x094d, 0x094d), -- Devanagari Sign Virama ..Devanagari Sign Virama

146+ (0x0951, 0x0957), -- Devanagari Stress Sign U..Devanagari Vowel Sign Uu

147+ (0x0962, 0x0963), -- Devanagari Vowel Sign Vo..Devanagari Vowel Sign Vo

148+ (0x0981, 0x0981), -- Bengali Sign Candrabindu..Bengali Sign Candrabindu

149+ (0x09bc, 0x09bc), -- Bengali Sign Nukta ..Bengali Sign Nukta

150+ (0x09c1, 0x09c4), -- Bengali Vowel Sign U ..Bengali Vowel Sign Vocal

151+ (0x09cd, 0x09cd), -- Bengali Sign Virama ..Bengali Sign Virama

152+ (0x09e2, 0x09e3), -- Bengali Vowel Sign Vocal..Bengali Vowel Sign Vocal

153+ (0x0a01, 0x0a02), -- Gurmukhi Sign Adak Bindi..Gurmukhi Sign Bindi

154+ (0x0a3c, 0x0a3c), -- Gurmukhi Sign Nukta ..Gurmukhi Sign Nukta

155+ (0x0a41, 0x0a42), -- Gurmukhi Vowel Sign U ..Gurmukhi Vowel Sign Uu

156+ (0x0a47, 0x0a48), -- Gurmukhi Vowel Sign Ee ..Gurmukhi Vowel Sign Ai

157+ (0x0a4b, 0x0a4d), -- Gurmukhi Vowel Sign Oo ..Gurmukhi Sign Virama

158+ (0x0a51, 0x0a51), -- Gurmukhi Sign Udaat ..Gurmukhi Sign Udaat

159+ (0x0a70, 0x0a71), -- Gurmukhi Tippi ..Gurmukhi Addak

160+ (0x0a75, 0x0a75), -- Gurmukhi Sign Yakash ..Gurmukhi Sign Yakash

161+ (0x0a81, 0x0a82), -- Gujarati Sign Candrabind..Gujarati Sign Anusvara

162+ (0x0abc, 0x0abc), -- Gujarati Sign Nukta ..Gujarati Sign Nukta

163+ (0x0ac1, 0x0ac5), -- Gujarati Vowel Sign U ..Gujarati Vowel Sign Cand

164+ (0x0ac7, 0x0ac8), -- Gujarati Vowel Sign E ..Gujarati Vowel Sign Ai

165+ (0x0acd, 0x0acd), -- Gujarati Sign Virama ..Gujarati Sign Virama

166+ (0x0ae2, 0x0ae3), -- Gujarati Vowel Sign Voca..Gujarati Vowel Sign Voca

167+ (0x0b01, 0x0b01), -- Oriya Sign Candrabindu ..Oriya Sign Candrabindu

168+ (0x0b3c, 0x0b3c), -- Oriya Sign Nukta ..Oriya Sign Nukta

169+ (0x0b3f, 0x0b3f), -- Oriya Vowel Sign I ..Oriya Vowel Sign I

170+ (0x0b41, 0x0b44), -- Oriya Vowel Sign U ..Oriya Vowel Sign Vocalic

171+ (0x0b4d, 0x0b4d), -- Oriya Sign Virama ..Oriya Sign Virama

172+ (0x0b56, 0x0b56), -- Oriya Ai Length Mark ..Oriya Ai Length Mark

173+ (0x0b62, 0x0b63), -- Oriya Vowel Sign Vocalic..Oriya Vowel Sign Vocalic

174+ (0x0b82, 0x0b82), -- Tamil Sign Anusvara ..Tamil Sign Anusvara

175+ (0x0bc0, 0x0bc0), -- Tamil Vowel Sign Ii ..Tamil Vowel Sign Ii

176+ (0x0bcd, 0x0bcd), -- Tamil Sign Virama ..Tamil Sign Virama

177+ (0x0c00, 0x0c00), -- Telugu Sign Combining Ca..Telugu Sign Combining Ca

178+ (0x0c3e, 0x0c40), -- Telugu Vowel Sign Aa ..Telugu Vowel Sign Ii

179+ (0x0c46, 0x0c48), -- Telugu Vowel Sign E ..Telugu Vowel Sign Ai

180+ (0x0c4a, 0x0c4d), -- Telugu Vowel Sign O ..Telugu Sign Virama

181+ (0x0c55, 0x0c56), -- Telugu Length Mark ..Telugu Ai Length Mark

182+ (0x0c62, 0x0c63), -- Telugu Vowel Sign Vocali..Telugu Vowel Sign Vocali

183+ (0x0c81, 0x0c81), -- Kannada Sign Candrabindu..Kannada Sign Candrabindu

184+ (0x0cbc, 0x0cbc), -- Kannada Sign Nukta ..Kannada Sign Nukta

185+ (0x0cbf, 0x0cbf), -- Kannada Vowel Sign I ..Kannada Vowel Sign I

186+ (0x0cc6, 0x0cc6), -- Kannada Vowel Sign E ..Kannada Vowel Sign E

187+ (0x0ccc, 0x0ccd), -- Kannada Vowel Sign Au ..Kannada Sign Virama

188+ (0x0ce2, 0x0ce3), -- Kannada Vowel Sign Vocal..Kannada Vowel Sign Vocal

189+ (0x0d01, 0x0d01), -- Malayalam Sign Candrabin..Malayalam Sign Candrabin

190+ (0x0d41, 0x0d44), -- Malayalam Vowel Sign U ..Malayalam Vowel Sign Voc

191+ (0x0d4d, 0x0d4d), -- Malayalam Sign Virama ..Malayalam Sign Virama

192+ (0x0d62, 0x0d63), -- Malayalam Vowel Sign Voc..Malayalam Vowel Sign Voc

193+ (0x0dca, 0x0dca), -- Sinhala Sign Al-lakuna ..Sinhala Sign Al-lakuna

194+ (0x0dd2, 0x0dd4), -- Sinhala Vowel Sign Ketti..Sinhala Vowel Sign Ketti

195+ (0x0dd6, 0x0dd6), -- Sinhala Vowel Sign Diga ..Sinhala Vowel Sign Diga

196+ (0x0e31, 0x0e31), -- Thai Character Mai Han-a..Thai Character Mai Han-a

197+ (0x0e34, 0x0e3a), -- Thai Character Sara I ..Thai Character Phinthu

198+ (0x0e47, 0x0e4e), -- Thai Character Maitaikhu..Thai Character Yamakkan

199+ (0x0eb1, 0x0eb1), -- Lao Vowel Sign Mai Kan ..Lao Vowel Sign Mai Kan

200+ (0x0eb4, 0x0eb9), -- Lao Vowel Sign I ..Lao Vowel Sign Uu

201+ (0x0ebb, 0x0ebc), -- Lao Vowel Sign Mai Kon ..Lao Semivowel Sign Lo

202+ (0x0ec8, 0x0ecd), -- Lao Tone Mai Ek ..Lao Niggahita

203+ (0x0f18, 0x0f19), -- Tibetan Astrological Sig..Tibetan Astrological Sig

204+ (0x0f35, 0x0f35), -- Tibetan Mark Ngas Bzung ..Tibetan Mark Ngas Bzung

205+ (0x0f37, 0x0f37), -- Tibetan Mark Ngas Bzung ..Tibetan Mark Ngas Bzung

206+ (0x0f39, 0x0f39), -- Tibetan Mark Tsa -phru ..Tibetan Mark Tsa -phru

207+ (0x0f71, 0x0f7e), -- Tibetan Vowel Sign Aa ..Tibetan Sign Rjes Su Nga

208+ (0x0f80, 0x0f84), -- Tibetan Vowel Sign Rever..Tibetan Mark Halanta

209+ (0x0f86, 0x0f87), -- Tibetan Sign Lci Rtags ..Tibetan Sign Yang Rtags

210+ (0x0f8d, 0x0f97), -- Tibetan Subjoined Sign L..Tibetan Subjoined Letter

211+ (0x0f99, 0x0fbc), -- Tibetan Subjoined Letter..Tibetan Subjoined Letter

212+ (0x0fc6, 0x0fc6), -- Tibetan Symbol Padma Gda..Tibetan Symbol Padma Gda

213+ (0x102d, 0x1030), -- Myanmar Vowel Sign I ..Myanmar Vowel Sign Uu

214+ (0x1032, 0x1037), -- Myanmar Vowel Sign Ai ..Myanmar Sign Dot Below

215+ (0x1039, 0x103a), -- Myanmar Sign Virama ..Myanmar Sign Asat

216+ (0x103d, 0x103e), -- Myanmar Consonant Sign M..Myanmar Consonant Sign M

217+ (0x1058, 0x1059), -- Myanmar Vowel Sign Vocal..Myanmar Vowel Sign Vocal

218+ (0x105e, 0x1060), -- Myanmar Consonant Sign M..Myanmar Consonant Sign M

219+ (0x1071, 0x1074), -- Myanmar Vowel Sign Geba ..Myanmar Vowel Sign Kayah

220+ (0x1082, 0x1082), -- Myanmar Consonant Sign S..Myanmar Consonant Sign S

221+ (0x1085, 0x1086), -- Myanmar Vowel Sign Shan ..Myanmar Vowel Sign Shan

222+ (0x108d, 0x108d), -- Myanmar Sign Shan Counci..Myanmar Sign Shan Counci

223+ (0x109d, 0x109d), -- Myanmar Vowel Sign Aiton..Myanmar Vowel Sign Aiton

224+ (0x135d, 0x135f), -- Ethiopic Combining Gemin..Ethiopic Combining Gemin

225+ (0x1712, 0x1714), -- Tagalog Vowel Sign I ..Tagalog Sign Virama

226+ (0x1732, 0x1734), -- Hanunoo Vowel Sign I ..Hanunoo Sign Pamudpod

227+ (0x1752, 0x1753), -- Buhid Vowel Sign I ..Buhid Vowel Sign U

228+ (0x1772, 0x1773), -- Tagbanwa Vowel Sign I ..Tagbanwa Vowel Sign U

229+ (0x17b4, 0x17b5), -- Khmer Vowel Inherent Aq ..Khmer Vowel Inherent Aa

230+ (0x17b7, 0x17bd), -- Khmer Vowel Sign I ..Khmer Vowel Sign Ua

231+ (0x17c6, 0x17c6), -- Khmer Sign Nikahit ..Khmer Sign Nikahit

232+ (0x17c9, 0x17d3), -- Khmer Sign Muusikatoan ..Khmer Sign Bathamasat

233+ (0x17dd, 0x17dd), -- Khmer Sign Atthacan ..Khmer Sign Atthacan

234+ (0x180b, 0x180d), -- Mongolian Free Variation..Mongolian Free Variation

235+ (0x1885, 0x1886), -- Mongolian Letter Ali Gal..Mongolian Letter Ali Gal

236+ (0x18a9, 0x18a9), -- Mongolian Letter Ali Gal..Mongolian Letter Ali Gal

237+ (0x1920, 0x1922), -- Limbu Vowel Sign A ..Limbu Vowel Sign U

238+ (0x1927, 0x1928), -- Limbu Vowel Sign E ..Limbu Vowel Sign O

239+ (0x1932, 0x1932), -- Limbu Small Letter Anusv..Limbu Small Letter Anusv

240+ (0x1939, 0x193b), -- Limbu Sign Mukphreng ..Limbu Sign Sa-i

241+ (0x1a17, 0x1a18), -- Buginese Vowel Sign I ..Buginese Vowel Sign U

242+ (0x1a1b, 0x1a1b), -- Buginese Vowel Sign Ae ..Buginese Vowel Sign Ae

243+ (0x1a56, 0x1a56), -- Tai Tham Consonant Sign ..Tai Tham Consonant Sign

244+ (0x1a58, 0x1a5e), -- Tai Tham Sign Mai Kang L..Tai Tham Consonant Sign

245+ (0x1a60, 0x1a60), -- Tai Tham Sign Sakot ..Tai Tham Sign Sakot

246+ (0x1a62, 0x1a62), -- Tai Tham Vowel Sign Mai ..Tai Tham Vowel Sign Mai

247+ (0x1a65, 0x1a6c), -- Tai Tham Vowel Sign I ..Tai Tham Vowel Sign Oa B

248+ (0x1a73, 0x1a7c), -- Tai Tham Vowel Sign Oa A..Tai Tham Sign Khuen-lue

249+ (0x1a7f, 0x1a7f), -- Tai Tham Combining Crypt..Tai Tham Combining Crypt

250+ (0x1ab0, 0x1abe), -- Combining Doubled Circum..Combining Parentheses Ov

251+ (0x1b00, 0x1b03), -- Balinese Sign Ulu Ricem ..Balinese Sign Surang

252+ (0x1b34, 0x1b34), -- Balinese Sign Rerekan ..Balinese Sign Rerekan

253+ (0x1b36, 0x1b3a), -- Balinese Vowel Sign Ulu ..Balinese Vowel Sign Ra R

254+ (0x1b3c, 0x1b3c), -- Balinese Vowel Sign La L..Balinese Vowel Sign La L

255+ (0x1b42, 0x1b42), -- Balinese Vowel Sign Pepe..Balinese Vowel Sign Pepe

256+ (0x1b6b, 0x1b73), -- Balinese Musical Symbol ..Balinese Musical Symbol

257+ (0x1b80, 0x1b81), -- Sundanese Sign Panyecek ..Sundanese Sign Panglayar

258+ (0x1ba2, 0x1ba5), -- Sundanese Consonant Sign..Sundanese Vowel Sign Pan

259+ (0x1ba8, 0x1ba9), -- Sundanese Vowel Sign Pam..Sundanese Vowel Sign Pan

260+ (0x1bab, 0x1bad), -- Sundanese Sign Virama ..Sundanese Consonant Sign

261+ (0x1be6, 0x1be6), -- Batak Sign Tompi ..Batak Sign Tompi

262+ (0x1be8, 0x1be9), -- Batak Vowel Sign Pakpak ..Batak Vowel Sign Ee

263+ (0x1bed, 0x1bed), -- Batak Vowel Sign Karo O ..Batak Vowel Sign Karo O

264+ (0x1bef, 0x1bf1), -- Batak Vowel Sign U For S..Batak Consonant Sign H

265+ (0x1c2c, 0x1c33), -- Lepcha Vowel Sign E ..Lepcha Consonant Sign T

266+ (0x1c36, 0x1c37), -- Lepcha Sign Ran ..Lepcha Sign Nukta

267+ (0x1cd0, 0x1cd2), -- Vedic Tone Karshana ..Vedic Tone Prenkha

268+ (0x1cd4, 0x1ce0), -- Vedic Sign Yajurvedic Mi..Vedic Tone Rigvedic Kash

269+ (0x1ce2, 0x1ce8), -- Vedic Sign Visarga Svari..Vedic Sign Visarga Anuda

270+ (0x1ced, 0x1ced), -- Vedic Sign Tiryak ..Vedic Sign Tiryak

271+ (0x1cf4, 0x1cf4), -- Vedic Tone Candra Above ..Vedic Tone Candra Above

272+ (0x1cf8, 0x1cf9), -- Vedic Tone Ring Above ..Vedic Tone Double Ring A

273+ (0x1dc0, 0x1df5), -- Combining Dotted Grave A..Combining Up Tack Above

274+ (0x1dfb, 0x1dff), -- (nil) ..Combining Right Arrowhea

275+ (0x20d0, 0x20f0), -- Combining Left Harpoon A..Combining Asterisk Above

276+ (0x2cef, 0x2cf1), -- Coptic Combining Ni Abov..Coptic Combining Spiritu

277+ (0x2d7f, 0x2d7f), -- Tifinagh Consonant Joine..Tifinagh Consonant Joine

278+ (0x2de0, 0x2dff), -- Combining Cyrillic Lette..Combining Cyrillic Lette

279+ (0x302a, 0x302d), -- Ideographic Level Tone M..Ideographic Entering Ton

280+ (0x3099, 0x309a), -- Combining Katakana-hirag..Combining Katakana-hirag

281+ (0xa66f, 0xa672), -- Combining Cyrillic Vzmet..Combining Cyrillic Thous

282+ (0xa674, 0xa67d), -- Combining Cyrillic Lette..Combining Cyrillic Payer

283+ (0xa69e, 0xa69f), -- Combining Cyrillic Lette..Combining Cyrillic Lette

284+ (0xa6f0, 0xa6f1), -- Bamum Combining Mark Koq..Bamum Combining Mark Tuk

285+ (0xa802, 0xa802), -- Syloti Nagri Sign Dvisva..Syloti Nagri Sign Dvisva

286+ (0xa806, 0xa806), -- Syloti Nagri Sign Hasant..Syloti Nagri Sign Hasant

287+ (0xa80b, 0xa80b), -- Syloti Nagri Sign Anusva..Syloti Nagri Sign Anusva

288+ (0xa825, 0xa826), -- Syloti Nagri Vowel Sign ..Syloti Nagri Vowel Sign

289+ (0xa8c4, 0xa8c5), -- Saurashtra Sign Virama ..

290+ (0xa8e0, 0xa8f1), -- Combining Devanagari Dig..Combining Devanagari Sig

291+ (0xa926, 0xa92d), -- Kayah Li Vowel Ue ..Kayah Li Tone Calya Plop

292+ (0xa947, 0xa951), -- Rejang Vowel Sign I ..Rejang Consonant Sign R

293+ (0xa980, 0xa982), -- Javanese Sign Panyangga ..Javanese Sign Layar

294+ (0xa9b3, 0xa9b3), -- Javanese Sign Cecak Telu..Javanese Sign Cecak Telu

295+ (0xa9b6, 0xa9b9), -- Javanese Vowel Sign Wulu..Javanese Vowel Sign Suku

296+ (0xa9bc, 0xa9bc), -- Javanese Vowel Sign Pepe..Javanese Vowel Sign Pepe

297+ (0xa9e5, 0xa9e5), -- Myanmar Sign Shan Saw ..Myanmar Sign Shan Saw

298+ (0xaa29, 0xaa2e), -- Cham Vowel Sign Aa ..Cham Vowel Sign Oe

299+ (0xaa31, 0xaa32), -- Cham Vowel Sign Au ..Cham Vowel Sign Ue

300+ (0xaa35, 0xaa36), -- Cham Consonant Sign La ..Cham Consonant Sign Wa

301+ (0xaa43, 0xaa43), -- Cham Consonant Sign Fina..Cham Consonant Sign Fina

302+ (0xaa4c, 0xaa4c), -- Cham Consonant Sign Fina..Cham Consonant Sign Fina

303+ (0xaa7c, 0xaa7c), -- Myanmar Sign Tai Laing T..Myanmar Sign Tai Laing T

304+ (0xaab0, 0xaab0), -- Tai Viet Mai Kang ..Tai Viet Mai Kang

305+ (0xaab2, 0xaab4), -- Tai Viet Vowel I ..Tai Viet Vowel U

306+ (0xaab7, 0xaab8), -- Tai Viet Mai Khit ..Tai Viet Vowel Ia

307+ (0xaabe, 0xaabf), -- Tai Viet Vowel Am ..Tai Viet Tone Mai Ek

308+ (0xaac1, 0xaac1), -- Tai Viet Tone Mai Tho ..Tai Viet Tone Mai Tho

309+ (0xaaec, 0xaaed), -- Meetei Mayek Vowel Sign ..Meetei Mayek Vowel Sign

310+ (0xaaf6, 0xaaf6), -- Meetei Mayek Virama ..Meetei Mayek Virama

311+ (0xabe5, 0xabe5), -- Meetei Mayek Vowel Sign ..Meetei Mayek Vowel Sign

312+ (0xabe8, 0xabe8), -- Meetei Mayek Vowel Sign ..Meetei Mayek Vowel Sign

313+ (0xabed, 0xabed), -- Meetei Mayek Apun Iyek ..Meetei Mayek Apun Iyek

314+ (0xfb1e, 0xfb1e), -- Hebrew Point Judeo-spani..Hebrew Point Judeo-spani

315+ (0xfe00, 0xfe0f), -- Variation Selector-1 ..Variation Selector-16

316+ (0xfe20, 0xfe2f), -- Combining Ligature Left ..Combining Cyrillic Titlo

317+ (0x101fd, 0x101fd), -- Phaistos Disc Sign Combi..Phaistos Disc Sign Combi

318+ (0x102e0, 0x102e0), -- Coptic Epact Thousands M..Coptic Epact Thousands M

319+ (0x10376, 0x1037a), -- Combining Old Permic Let..Combining Old Permic Let

320+ (0x10a01, 0x10a03), -- Kharoshthi Vowel Sign I ..Kharoshthi Vowel Sign Vo

321+ (0x10a05, 0x10a06), -- Kharoshthi Vowel Sign E ..Kharoshthi Vowel Sign O

322+ (0x10a0c, 0x10a0f), -- Kharoshthi Vowel Length ..Kharoshthi Sign Visarga

323+ (0x10a38, 0x10a3a), -- Kharoshthi Sign Bar Abov..Kharoshthi Sign Dot Belo

324+ (0x10a3f, 0x10a3f), -- Kharoshthi Virama ..Kharoshthi Virama

325+ (0x10ae5, 0x10ae6), -- Manichaean Abbreviation ..Manichaean Abbreviation

326+ (0x11001, 0x11001), -- Brahmi Sign Anusvara ..Brahmi Sign Anusvara

327+ (0x11038, 0x11046), -- Brahmi Vowel Sign Aa ..Brahmi Virama

328+ (0x1107f, 0x11081), -- Brahmi Number Joiner ..Kaithi Sign Anusvara

329+ (0x110b3, 0x110b6), -- Kaithi Vowel Sign U ..Kaithi Vowel Sign Ai

330+ (0x110b9, 0x110ba), -- Kaithi Sign Virama ..Kaithi Sign Nukta

331+ (0x11100, 0x11102), -- Chakma Sign Candrabindu ..Chakma Sign Visarga

332+ (0x11127, 0x1112b), -- Chakma Vowel Sign A ..Chakma Vowel Sign Uu

333+ (0x1112d, 0x11134), -- Chakma Vowel Sign Ai ..Chakma Maayyaa

334+ (0x11173, 0x11173), -- Mahajani Sign Nukta ..Mahajani Sign Nukta

335+ (0x11180, 0x11181), -- Sharada Sign Candrabindu..Sharada Sign Anusvara

336+ (0x111b6, 0x111be), -- Sharada Vowel Sign U ..Sharada Vowel Sign O

337+ (0x111ca, 0x111cc), -- Sharada Sign Nukta ..Sharada Extra Short Vowe

338+ (0x1122f, 0x11231), -- Khojki Vowel Sign U ..Khojki Vowel Sign Ai

339+ (0x11234, 0x11234), -- Khojki Sign Anusvara ..Khojki Sign Anusvara

340+ (0x11236, 0x11237), -- Khojki Sign Nukta ..Khojki Sign Shadda

341+ (0x1123e, 0x1123e), -- (nil) ..

342+ (0x112df, 0x112df), -- Khudawadi Sign Anusvara ..Khudawadi Sign Anusvara

343+ (0x112e3, 0x112ea), -- Khudawadi Vowel Sign U ..Khudawadi Sign Virama

344+ (0x11300, 0x11301), -- Grantha Sign Combining A..Grantha Sign Candrabindu

345+ (0x1133c, 0x1133c), -- Grantha Sign Nukta ..Grantha Sign Nukta

346+ (0x11340, 0x11340), -- Grantha Vowel Sign Ii ..Grantha Vowel Sign Ii

347+ (0x11366, 0x1136c), -- Combining Grantha Digit ..Combining Grantha Digit

348+ (0x11370, 0x11374), -- Combining Grantha Letter..Combining Grantha Letter

349+ (0x11438, 0x1143f), -- (nil) ..

350+ (0x11442, 0x11444), -- (nil) ..

351+ (0x11446, 0x11446), -- (nil) ..

352+ (0x114b3, 0x114b8), -- Tirhuta Vowel Sign U ..Tirhuta Vowel Sign Vocal

353+ (0x114ba, 0x114ba), -- Tirhuta Vowel Sign Short..Tirhuta Vowel Sign Short

354+ (0x114bf, 0x114c0), -- Tirhuta Sign Candrabindu..Tirhuta Sign Anusvara

355+ (0x114c2, 0x114c3), -- Tirhuta Sign Virama ..Tirhuta Sign Nukta

356+ (0x115b2, 0x115b5), -- Siddham Vowel Sign U ..Siddham Vowel Sign Vocal

357+ (0x115bc, 0x115bd), -- Siddham Sign Candrabindu..Siddham Sign Anusvara

358+ (0x115bf, 0x115c0), -- Siddham Sign Virama ..Siddham Sign Nukta

359+ (0x115dc, 0x115dd), -- Siddham Vowel Sign Alter..Siddham Vowel Sign Alter

360+ (0x11633, 0x1163a), -- Modi Vowel Sign U ..Modi Vowel Sign Ai

361+ (0x1163d, 0x1163d), -- Modi Sign Anusvara ..Modi Sign Anusvara

362+ (0x1163f, 0x11640), -- Modi Sign Virama ..Modi Sign Ardhacandra

363+ (0x116ab, 0x116ab), -- Takri Sign Anusvara ..Takri Sign Anusvara

364+ (0x116ad, 0x116ad), -- Takri Vowel Sign Aa ..Takri Vowel Sign Aa

365+ (0x116b0, 0x116b5), -- Takri Vowel Sign U ..Takri Vowel Sign Au

366+ (0x116b7, 0x116b7), -- Takri Sign Nukta ..Takri Sign Nukta

367+ (0x1171d, 0x1171f), -- Ahom Consonant Sign Medi..Ahom Consonant Sign Medi

368+ (0x11722, 0x11725), -- Ahom Vowel Sign I ..Ahom Vowel Sign Uu

369+ (0x11727, 0x1172b), -- Ahom Vowel Sign Aw ..Ahom Sign Killer

370+ (0x11c30, 0x11c36), -- (nil) ..

371+ (0x11c38, 0x11c3d), -- (nil) ..

372+ (0x11c3f, 0x11c3f), -- (nil) ..

373+ (0x11c92, 0x11ca7), -- (nil) ..

374+ (0x11caa, 0x11cb0), -- (nil) ..

375+ (0x11cb2, 0x11cb3), -- (nil) ..

376+ (0x11cb5, 0x11cb6), -- (nil) ..

377+ (0x16af0, 0x16af4), -- Bassa Vah Combining High..Bassa Vah Combining High

378+ (0x16b30, 0x16b36), -- Pahawh Hmong Mark Cim Tu..Pahawh Hmong Mark Cim Ta

379+ (0x16f8f, 0x16f92), -- Miao Tone Right ..Miao Tone Below

380+ (0x1bc9d, 0x1bc9e), -- Duployan Thick Letter Se..Duployan Double Mark

381+ (0x1d167, 0x1d169), -- Musical Symbol Combining..Musical Symbol Combining

382+ (0x1d17b, 0x1d182), -- Musical Symbol Combining..Musical Symbol Combining

383+ (0x1d185, 0x1d18b), -- Musical Symbol Combining..Musical Symbol Combining

384+ (0x1d1aa, 0x1d1ad), -- Musical Symbol Combining..Musical Symbol Combining

385+ (0x1d242, 0x1d244), -- Combining Greek Musical ..Combining Greek Musical

386+ (0x1da00, 0x1da36), -- Signwriting Head Rim ..Signwriting Air Sucking

387+ (0x1da3b, 0x1da6c), -- Signwriting Mouth Closed..Signwriting Excitement

388+ (0x1da75, 0x1da75), -- Signwriting Upper Body T..Signwriting Upper Body T

389+ (0x1da84, 0x1da84), -- Signwriting Location Hea..Signwriting Location Hea

390+ (0x1da9b, 0x1da9f), -- Signwriting Fill Modifie..Signwriting Fill Modifie

391+ (0x1daa1, 0x1daaf), -- Signwriting Rotation Mod..Signwriting Rotation Mod

392+ (0x1e000, 0x1e006), -- (nil) ..

393+ (0x1e008, 0x1e018), -- (nil) ..

394+ (0x1e01b, 0x1e021), -- (nil) ..

395+ (0x1e023, 0x1e024), -- (nil) ..

396+ (0x1e026, 0x1e02a), -- (nil) ..

397+ (0x1e8d0, 0x1e8d6), -- Mende Kikakui Combining ..Mende Kikakui Combining

398+ (0x1e944, 0x1e94a), -- (nil) ..

399+ (0xe0100, 0xe01ef) -- Variation Selector-17 ..Variation Selector-256

400+ ]

401+

402+

403+basicZero :: RangeSet Int

404+basicZero = foldr insertRange empty [

405+ (0, 0),

406+ (0x034f, 0x034f),

407+ (0x200b, 0x200f),

408+ (0x2028, 0x2029),

409+ (0x202a, 0x202e),

410+ (0x2060, 0x2063)

411+ ]

412+

413+ctrlChars :: RangeSet Int

414+ctrlChars = foldr insertRange empty [

415+ (1, 32),

416+ (0x07f, 0x09F)

417+ ]

418+

419+wcwidth :: Char -> Int

420+wcwidth c | queryPoint v basicZero = 0

421+ | queryPoint v ctrlChars = -1

422+ | queryPoint v wIDEEASTASIAN = 2

423+ | queryPoint v zEROWIDTH = 0

424+ | otherwise = 1

425+ where v = ord c

stack.ghc7.10.yamldeleted−50

@@ -1,50 +0,0 @@

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

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−- data-accessor-transformers-0.2.1.7

13−- data-interval-1.2.0

14−- extended-reals-0.2.1.0

15−- gnuplot-0.5.4.1

16−- text-1.2.2.1

17−- aeson-1.2.1.00

18−- distributed-process-0.6.6

19−- distributed-process-async-0.2.4

20−- distributed-process-client-server-0.2.3

21−- distributed-process-extras-0.3.2

22−- cryptohash-sha256-0.11.100.1

23−- megaparsec-5.3.1

24−

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

26−flags: {}

27−

28−# Extra package databases containing global packages

29−extra-package-dbs: []

30−

31−# Control whether we use the GHC we find on the path

32−# system-ghc: true

33−

34−# Require a specific version of stack, using version ranges

35−# require-stack-version: -any # Default

36−# require-stack-version: >= 1.0.0

37−

38−# Override the architecture used by stack, especially useful on Windows

39−# arch: i386

40−# arch: x86_64

41−

42−# Extra directories used by stack for building

43−# extra-include-dirs: [/path/to/dir]

44−# extra-lib-dirs: [/path/to/dir]

45−

46−# Allow a newer minor version of GHC than the snapshot specifies

47−# compiler-check: newer-minor

48−

49−allow-newer: true

50−

stack.yamldeleted−1

@@ -1 +0,0 @@

1−stack.ghc8.0.yaml

test/Relation/Atomable.hs+11−2

@@ -31,6 +31,9 @@ data Test4T = Test4Ca Integer |

3131data TestListT = TestListC [Integer]

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

3333

34+data TestNonEmptyT = TestNonEmptyC [Integer]

35+ deriving (Show, Generic, Eq, Binary, NFData, Atomable)

36+

3437data Test5T = Test5C {

3538 con1 :: Integer,

3639 con2 :: Integer

@@ -48,7 +51,8 @@ main = do

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

4952

5053testList :: Test

51−testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testListInstance, testADT6Maybe, testADT7Either]

54+testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testListInstance, testNonEmptyInstance, testADT6Maybe, testADT7Either]

55+

5256

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

5458testBasicMarshaling :: Test

@@ -131,4 +135,9 @@ checkExecuteDatabaseContextExpr sessionId dbconn expr = executeDatabaseContextEx

131135testListInstance :: Test

132136testListInstance = TestCase $ do

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

134− assertEqual "List instance" example (fromAtom (toAtom example))

138+ assertEqual "List instance" example (fromAtom (toAtom example))

139+

140+testNonEmptyInstance :: Test

141+testNonEmptyInstance = TestCase $ do

142+ let example = TestNonEmptyC [3,4,5]

143+ assertEqual "NonEmpty instance" example (fromAtom (toAtom example))

test/Relation/Export/CSV.hs+3−3

@@ -57,7 +57,7 @@ testCSVExport = TestCase $ do

5757 Attribute "bytestringattr" ByteStringAtomType,

5858 Attribute "listintegerattr" (listAtomType IntegerAtomType),

5959 Attribute "listtextattr" (listAtomType TextAtomType),

60− Attribute "intervalattr" (IntervalAtomType DateTimeAtomType)

60+ Attribute "intervalattr" (intervalAtomType DateTimeAtomType)

6161 ]

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

6363 relOrErr = mkRelationFromList attrs [

@@ -70,7 +70,7 @@ testCSVExport = TestCase $ do

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

7171 testInterval

7272 ],

73− [TextAtom "second text atom",

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

7474 IntegerAtom 314,

7575 DayAtom (fromGregorian 1001 6 28),

7676 DateTimeAtom (addUTCTime 360 now),

@@ -85,7 +85,7 @@ testCSVExport = TestCase $ do

8585 Right rel ->

8686 case relationAsCSV rel of

8787 Left err -> assertFailure $ "export failed: " ++ show err

88− Right csvData ->

88+ Right csvData ->

8989 --BS.writeFile "/tmp/csv" csvData

9090 --putStrLn (TL.unpack (TE.decodeUtf8 csvData))

9191 case csvAsRelation attrs basicTypeConstructorMapping csvData of -- import csv data back to relation

test/Server/Main.hs+28−12

@@ -17,10 +17,17 @@ import System.Exit

1717

1818import Control.Concurrent

1919import Network.Transport (EndPointAddress)

20+

21+#if MIN_VERSION_network_transport_tcp(0,6,0)

2022import Network.Transport.TCP.Internal (encodeEndPointAddress, decodeEndPointAddress)

23+#else

24+import Network.Transport.TCP (encodeEndPointAddress, decodeEndPointAddress)

25+#endif

26+

2127import Data.Either (isRight)

2228import Control.Exception

23−--import Control.Monad.IO.Class

29+import System.IO.Temp

30+import System.FilePath

2431#if defined(linux_HOST_OS)

2532import System.Directory

2633#endif

@@ -43,7 +50,7 @@ testList sessionId conn notificationTestMVar = TestList $ serverTests ++ session

4350 testNotification notificationTestMVar

4451 ]

4552 serverTests = [testRequestTimeout, testFileDescriptorCount]

46−

53+

4754main :: IO ()

4855main = do

4956 (serverAddress, _) <- launchTestServer 0

@@ -80,13 +87,17 @@ testConnection serverAddress mvar = do

8087-- | A version of 'launchServer' which returns the port on which the server is listening on a secondary thread

8188launchTestServer :: Timeout -> IO (EndPointAddress, ThreadId)

8289launchTestServer ti = do

83− let config = defaultServerConfig { databaseName = testDatabaseName,

84− perRequestTimeout = ti,

85− testMode = True,

86− bindPort = 0

87− }

8890 addressMVar <- newEmptyMVar

89− tid <- forkIO $ launchServer config (Just addressMVar) >> pure ()

91+ tid <- forkIO $

92+ withSystemTempDirectory "projectm36test" $ \tempdir -> do

93+ let config = defaultServerConfig { databaseName = testDatabaseName,

94+ persistenceStrategy = CrashSafePersistence (tempdir </> "db"),

95+ perRequestTimeout = ti,

96+ testMode = True,

97+ bindPort = 0

98+ }

99+

100+ launchServer config (Just addressMVar) >> pure ()

90101 endPointAddress <- takeMVar addressMVar

91102 --liftIO $ putStrLn ("launched server on " ++ show endPointAddress)

92103 pure (endPointAddress, tid)

@@ -212,19 +223,24 @@ testFileDescriptorCount :: Test

212223--validate that creating a server, connecting a client, and then disconnecting doesn't leak file descriptors

213224testFileDescriptorCount = TestCase $ do

214225 (serverAddress, serverTid) <- launchTestServer 1000

215− startCount <- fdCount

216226 unusedMVar <- newEmptyMVar

217− Right (_, testConn) <- testConnection serverAddress unusedMVar

227+ startCount <- fdCount

228+ Right (sess, testConn) <- testConnection serverAddress unusedMVar

229+ --add a test commit to trigger the fsync machinery

230+ executeDatabaseContextExpr sess testConn (Assign "x" (ExistingRelation relationFalse)) >>= eitherFail

231+ commit sess testConn >>= eitherFail

218232 close testConn

219233 endCount <- fdCount

220− assertBool "fd leak" (endCount - startCount <= 1)

234+ let fd_diff = endCount - startCount

235+ assertBool ("fd leak: " ++ show fd_diff) (fd_diff <= 0)

221236 killThread serverTid

237+

222238

223239-- returns the number of open file descriptors -- linux only /proc usage

224240fdCount :: IO Int

225241fdCount = do

226242 fds <- getDirectoryContents "/proc/self/fd"

227− pure ((length fds) - 2)

243+ pure (length fds)

228244#else

229245--pass on non-linux platforms

230246testFileDescriptorCount = TestCase (pure ())

test/Server/WebSocket.hs+6

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

1+{-# LANGUAGE CPP #-}

12-- test the websocket server

23import Test.HUnit

34import qualified Network.WebSockets as WS

@@ -17,7 +18,12 @@ import Data.Aeson

1718import qualified Data.Map as M

1819import qualified Data.ByteString.Lazy as BS

1920import ProjectM36.Relation

21+#if MIN_VERSION_network_transport_tcp(0,6,0)

2022import Network.Transport.TCP.Internal (decodeEndPointAddress)

23+#else

24+import Network.Transport.TCP (decodeEndPointAddress)

25+#endif

26+

2127

2228--start the websocket server

2329-- run some tutoriald against it

test/TutorialD/Interpreter.hs+101−6

@@ -10,6 +10,9 @@ import ProjectM36.Error

1010import ProjectM36.DatabaseContext

1111import ProjectM36.AtomFunctions.Primitive

1212import ProjectM36.DataTypes.Either

13+import ProjectM36.DataTypes.Interval

14+import ProjectM36.DataTypes.NonEmptyList

15+import ProjectM36.DataTypes.List

1316import ProjectM36.DateExamples

1417import ProjectM36.Base hiding (Finite)

1518import ProjectM36.TransactionGraph

@@ -29,20 +32,22 @@ import Data.Text hiding (map)

2932import qualified Data.Text as T

3033import Data.Time.Clock.POSIX hiding (getCurrentTime)

3134import Data.Time.Clock (getCurrentTime)

35+import Data.Time.Calendar (fromGregorian)

3236

3337main :: IO ()

3438main = do

3539 tcounts <- runTestTT (TestList tests)

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

3741 where

38− tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [

42+ tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++

43+ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [

3944 transactionGraphBasicTest,

4045 transactionGraphAddCommitTest,

4146 transactionRollbackTest,

4247 transactionJumpTest,

4348 transactionBranchTest,

4449 simpleJoinTest,

45− testNotification,

50+ testNotification,

4651 testTypeConstructors,

4752 testMergeTransactions,

4853 testComments,

@@ -59,7 +64,15 @@ main = do

5964 testRestrictionPredicateExprs,

6065 testRelationalAttributeNames,

6166 testSemijoin,

62− testAntijoin

67+ testAntijoin,

68+ testRelationAttributeDefinition,

69+ testAssignWithTypeVar,

70+ testDefineWithTypeVar,

71+ testIntervalType,

72+ testArbitraryRelation,

73+ testNonEmptyListType,

74+ testUnresolvedAtomTypes,

75+ testWithClause

6376 ]

6477 simpleRelTests = [("x:=true", Right relationTrue),

6578 ("x:=false", Right relationFalse),

@@ -86,7 +99,7 @@ main = do

8699 ("x:=true=true", Right relationTrue),

87100 ("x:=true=false", Right relationFalse),

88101 ("x:=true; undefine x", Left (RelVarNotDefinedError "x")),

89− ("x:=relation {b Integer, a Text}{}; insert x relation{tuple{b 5, a \"spam\"}}", mkRelationFromTuples simpleCAttributes [RelationTuple simpleCAttributes $ V.fromList [TextAtom "spam", IntegerAtom 5]]),

102+ ("x:=relation {b Integer, a Text}{}; insert x relation{tuple{b -5, a \"spam\"}}", mkRelationFromTuples simpleCAttributes [RelationTuple simpleCAttributes $ V.fromList [TextAtom "spam", IntegerAtom (-5)]]),

90103 -- test nested relation constructor

91104 ("x:=relation{tuple{a 5, b relation{tuple{a 6}}}}", mkRelation nestedRelationAttributes $ RelationTupleSet [RelationTuple nestedRelationAttributes (V.fromList [IntegerAtom 5, RelationAtom (Relation simpleAAttributes $ RelationTupleSet [RelationTuple simpleAAttributes $ V.fromList [IntegerAtom 6]])])]),

92105 ("x:=relation{tuple{b 5,a \"spam\"},tuple{b 6,a \"sam\"}}; delete x where b=6", mkRelation simpleCAttributes $ RelationTupleSet [RelationTuple simpleCAttributes (V.fromList [TextAtom "spam", IntegerAtom 5])]),

@@ -152,10 +165,12 @@ main = do

152165 --test Maybe Integer

153166 ("x:=relation{tuple{a Just 3}}", mkRelationFromList simpleMaybeIntAttributes [[ConstructedAtom "Just" maybeIntegerAtomType [IntegerAtom 3]]]),

154167 --test Either Integer Text

155− ("x:=relation{tuple{a Left 3}}", Left (TypeConstructorTypeVarsMismatch (S.fromList ["a","b"]) (S.fromList ["a"]))), -- Left 3, alone is not enough information to imply the type

168+ ("x:=relation{tuple{a Left 3}}", Left (TypeConstructorTypeVarMissing "b")), -- Left 3, alone is not enough information to imply the type

156169 ("x:=relation{a Either Integer Text}{tuple{a Left 3}}", mkRelationFromList simpleEitherIntTextAttributes [[ConstructedAtom "Left" (eitherAtomType IntegerAtomType TextAtomType) [IntegerAtom 3]]]),

157170 --test datetime constructor

158− ("x:=relation{tuple{a dateTimeFromEpochSeconds(1495199790)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DateTimeAtomType]) [[DateTimeAtom (posixSecondsToUTCTime(realToFrac (1495199790 :: Int)))]])

171+ ("x:=relation{tuple{a dateTimeFromEpochSeconds(1495199790)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DateTimeAtomType]) [[DateTimeAtom (posixSecondsToUTCTime(realToFrac (1495199790 :: Int)))]]),

172+ --test Day constructor

173+ ("x:=relation{tuple{a fromGregorian(2017,05,30)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DayAtomType]) [[DayAtom (fromGregorian 2017 05 30)]])

159174 ]

160175

161176assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> Text -> Assertion

@@ -537,3 +552,83 @@ testAntijoin = TestCase $ do

537552 eY <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())

538553 assertEqual "antijoin only Adams" eX eY

539554

555+testRelationAttributeDefinition :: Test

556+testRelationAttributeDefinition = TestCase $ do

557+ -- test normal subrelation construction

558+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

559+ executeTutorialD sessionId dbconn "x:=relation{a relation{b Integer}}{tuple{a relation{tuple{b 4}}}}"

560+ eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())

561+ let expected = mkRelationFromList attrs [[RelationAtom subRel]]

562+ attrs = attributesFromList [Attribute "a" (RelationAtomType subRelAttrs)]

563+ subRelAttrs = attributesFromList [Attribute "b" IntegerAtomType]

564+ Right subRel = mkRelationFromList subRelAttrs [[IntegerAtom 4]]

565+ assertEqual "relation attribute construction" expected eX

566+ -- test rejected subrelation construction due to floating type variables

567+ expectTutorialDErr sessionId dbconn (T.isPrefixOf "TypeConstructorTypeVarMissing") "y:=relation{a relation{b x}}"

568+

569+testAssignWithTypeVar :: Test

570+testAssignWithTypeVar = TestCase $ do

571+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

572+ let err1 = "TypeConstructorTypeVarMissing"

573+ expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "y:=relation{a int, b invalidtype}"

574+

575+testDefineWithTypeVar :: Test

576+testDefineWithTypeVar = TestCase $ do

577+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

578+ let err1 = "TypeConstructorTypeVarMissing"

579+ expectTutorialDErr sessionId dbconn (T.isInfixOf err1) "y::{a int, b invalidtype}"

580+

581+testIntervalType :: Test

582+testIntervalType = TestCase $ do

583+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

584+ executeTutorialD sessionId dbconn "x:=relation{a Interval Integer}"

585+ eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())

586+ let expectedIntervalInt = mkRelationFromList expectedAttrs []

587+ expectedAttrs = A.attributesFromList [Attribute "a" (intervalAtomType IntegerAtomType)]

588+ assertEqual "Interval Int attribute" expectedIntervalInt eX

589+

590+testArbitraryRelation :: Test

591+testArbitraryRelation = TestCase $ do

592+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

593+ executeTutorialD sessionId dbconn "createarbitraryrelation rv1 {a Integer} 5-10"

594+ executeTutorialD sessionId dbconn "createarbitraryrelation rv2 {a Integer, b relation{c Integer}} 10-100"

595+ executeTutorialD sessionId dbconn "createarbitraryrelation rv3 {a Int, b relation{c Interval Int}} 3-100"

596+

597+testNonEmptyListType :: Test

598+testNonEmptyListType = TestCase $ do

599+ --create a NonEmptyList

600+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

601+ executeTutorialD sessionId dbconn "x:=relation{tuple{a NECons 3 (Cons 4 Empty)}} : {x:=nonEmptyListHead(@a)}"

602+ eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())

603+ let expected = mkRelationFromList attrs [[nelist, nehead]]

604+ attrs = attributesFromList [Attribute "a" neListType,

605+ Attribute "x" IntegerAtomType]

606+ neListType = nonEmptyListAtomType IntegerAtomType

607+ listType = listAtomType IntegerAtomType

608+ nelist = ConstructedAtom "NECons" (nonEmptyListAtomType IntegerAtomType) [

609+ IntegerAtom 3,

610+ ConstructedAtom "Cons" listType [IntegerAtom 4, ConstructedAtom "Empty" listType []]]

611+ nehead = IntegerAtom 3

612+ assertEqual "non-empty list type construction" expected eX

613+

614+testUnresolvedAtomTypes :: Test

615+testUnresolvedAtomTypes = TestCase $ do

616+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

617+ let err1 = "TypeConstructorTypeVarMissing"

618+ expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a Empty}}"

619+ executeTutorialD sessionId dbconn "x:=relation{a List Int}{tuple{a Empty}}"

620+

621+-- with (x as s) s

622+testWithClause :: Test

623+testWithClause = TestCase $ do

624+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

625+ executeTutorialD sessionId dbconn "x:=with (x as s) x"

626+ eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())

627+ assertEqual "with x as s" (Right suppliersRel) eX

628+

629+ let err1 = "RelVarAlreadyDefinedError"

630+ expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=with (s as s) s"

631+

632+ expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=with (s as sp) s"

633+

634+

test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs+4−10

@@ -14,18 +14,18 @@ main = do

1414 ])

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

1616

17−{-

18−adddatabasecontextfunction "addtruerv" DatabaseContext -> DatabaseContext """(\[] ctx -> execState (evalDatabaseContextExpr (Assign "true2" (ExistingRelation relationTrue))) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext"""

19−-}

2017testBasicDBCFunction :: Test

2118testBasicDBCFunction = TestCase $ do

2219 (sess, conn) <- dateExamplesConnection emptyNotificationCallback

2320 let addfunc = "adddatabasecontextfunction \"addTrue2\" DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\[] ctx -> executeDatabaseContextExpr (Assign \"true2\" (ExistingRelation relationTrue)) ctx) :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\""

2421 executeTutorialD sess conn addfunc

22+ putStrLn "spam1"

2523 executeTutorialD sess conn "execute addTrue2()"

24+ putStrLn "spam2"

25+ {-

2626 let true2Expr = RelationVariable "true2" ()

2727 result <- executeRelationalExpr sess conn true2Expr

28− assertEqual "simple atom function equality" (Right relationTrue) result

28+ assertEqual "simple atom function equality" (Right relationTrue) result-}

2929

3030testErrorDBCFunction :: Test

3131testErrorDBCFunction = TestCase $ do

@@ -43,9 +43,6 @@ testExceptionDBCFunction = TestCase $ do

4343 expectTutorialDErr sess conn (\err -> "UnhandledExceptionError" `T.isPrefixOf` err) "execute bomb()"

4444

4545

46−{-

47−adddatabasecontextfunction "multiArgFunc" Int -> Text -> DatabaseContext -> DatabaseContext """(\(age:name:_) ctx -> execState (evalDatabaseContextExpr (Assign "person" (MakeRelationFromExprs Nothing [TupleExpr (fromList [("name", NakedAtomExpr name), ("age", NakedAtomExpr age)])]))) ctx)"""

48−-}

4946testDBCFunctionWithAtomArguments :: Test

5047testDBCFunctionWithAtomArguments = TestCase $ do

5148 --test function with creation of a relvar with some arguments

@@ -60,7 +57,4 @@ testDBCFunctionWithAtomArguments = TestCase $ do

6057 assertEqual "person relation" expectedPerson result

6158 expectTutorialDErr sess conn (T.isPrefixOf "AtomTypeMismatchError") "execute multiArgFunc(\"fail\", \"fail\")"

6259

63−{-

64−adddatabasecontextfunction "addperson" Int -> Text -> DatabaseContext -> DatabaseContext """(\(age:name:_) ctx -> let newrel = MakeRelationFromExprs Nothing [TupleExpr (fromList [("name", name),("age",age))]] in if isRight (runState (executeRelationalExpr (RelationVariable "person" ()) ctx)) then execState (executeContextExpr (Insert "person" newrel)) ctx else execState (executeContextExpr (Assign "person" newrel)) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext"""

65−-}

6660

test/TutorialD/Interpreter/Import/TutorialD.hs+10−2

@@ -5,6 +5,8 @@ import System.Exit

55import System.IO.Temp

66import qualified Data.Map as M

77import System.IO

8+import qualified Data.ByteString as BS

9+import qualified Data.Text.Encoding as TE

810

911main :: IO ()

1012main = do

@@ -14,8 +16,14 @@ main = do

1416testTutdImport :: Test

1517testTutdImport = TestCase $

1618 withSystemTempFile "m.tutd" $ \tempPath handle -> do

17− hPutStrLn handle "x:=relation{tuple{a 5,b \"spam\"}}"

19+ BS.hPut handle (TE.encodeUtf8 "x:=relation{tuple{a 5,b \"spam\"}}; y:=relation{tuple{b \"漢字\"}}")

1820 hClose handle

19− let expectedExpr = MultipleExpr [Assign "x" (MakeRelationFromExprs Nothing [TupleExpr (M.fromList [("a",NakedAtomExpr $ IntegerAtom 5),("b",NakedAtomExpr $ TextAtom "spam")])])]

21+ let expectedExpr = MultipleExpr [

22+ Assign "x" (MakeRelationFromExprs Nothing

23+ [TupleExpr (M.fromList [("a", NakedAtomExpr $ IntegerAtom 5),

24+ ("b", NakedAtomExpr $ TextAtom "spam")])]),

25+ Assign "y" (MakeRelationFromExprs Nothing

26+ [TupleExpr (M.fromList [("b", NakedAtomExpr (TextAtom "漢字"))])])]

2027 imported <- importTutorialD tempPath

2128 assertEqual "import tutd" (Right expectedExpr) imported

29+

test/TutorialD/Interpreter/TestBase.hs+6−6

@@ -31,12 +31,12 @@ executeTutorialD sessionId conn tutd = case parseTutorialD tutd of

3131 Right parsed -> do

3232 result <- evalTutorialD sessionId conn UnsafeEvaluation parsed

3333 case result of

34− QuitResult -> assertFailure "quit?"

35− DisplayResult _ -> assertFailure "display?"

36− DisplayIOResult _ -> assertFailure "displayIO?"

37− DisplayRelationResult _ -> assertFailure "displayrelation?"

38− DisplayParseErrorResult _ _ -> assertFailure "displayparseerrorresult?"

39− DisplayErrorResult err -> assertFailure (show err)

34+ QuitResult -> putStrLn "yyy" >> assertFailure "quit?"

35+ DisplayResult _ -> putStrLn "xxx" >> assertFailure "display?"

36+ DisplayIOResult _ -> putStrLn "z" >> assertFailure "displayIO?"

37+ DisplayRelationResult _ -> putStrLn "Y" >> assertFailure "displayrelation?"

38+ DisplayParseErrorResult _ _ -> putStrLn "X" >> assertFailure "displayparseerrorresult?"

39+ DisplayErrorResult err -> putStrLn "asd" >> assertFailure (show tutd ++ ": " ++ show err)

4040 QuietSuccessResult -> pure ()

4141

4242expectTutorialDErr :: SessionId -> Connection -> (Text -> Bool) -> Text -> IO ()