1046167...master · project-m36

git.iko.soy/project-m36

150 files changed+5696−2628

since splitsnapshots

unifiedsplit

.appveyor.yml+2−3

@@ -17,8 +17,7 @@ environment:

1717 global:

1818 STACK_ROOT: "c:\\sr"

1919 matrix:

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

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

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

2221

2322platform:

2423 - x64

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

3736

3837#artifacts:

3938# - path: project-m36.7z

40−# name: project-m36.7z

39+# name: project-m36.7z

.github/workflows/ci.yamlnew file+69

@@ -0,0 +1,69 @@

1+name: "CI"

2+on:

3+ pull_request:

4+ push:

5+jobs:

6+ dockerimage:

7+ runs-on: ubuntu-latest

8+ steps:

9+ - uses: actions/checkout@v2.3.1

10+ - uses: cachix/install-nix-action@v12

11+ with:

12+ nix_path: nixpkgs=channel:nixos-unstable

13+ - uses: cachix/cachix-action@v8

14+ with:

15+ name: project-m36

16+ signingKey: "${{ secrets.CACHIX_SIGNING_KEY }}"

17+ - run: cachix use iohk

18+ - name: docker load

19+ run: docker load < $(nix-build docker.nix)

20+ - name: docker login

21+ if: ${{ github.ref == 'refs/heads/master' }}

22+ run: echo ${{secrets.DOCKERHUB_PASSWORD}} | docker login --username ${{secrets.DOCKERHUB_USER}} --password-stdin

23+ - name: docker tag with version

24+ run: docker tag project-m36:latest projectm36/project-m36:$(awk '/^Version:/ {print $2}' project-m36.cabal)

25+ if: ${{ github.ref == 'refs/heads/master' }}

26+ - name: docker tag latest

27+ run: docker tag project-m36:latest projectm36/project-m36:latest

28+ if: ${{ github.ref == 'refs/heads/master' }}

29+ - run: docker push projectm36/project-m36

30+ if: ${{ github.ref == 'refs/heads/master' }}

31+

32+ stack-build:

33+ runs-on: ${{ matrix.os }}

34+ strategy:

35+ matrix:

36+ os: [ubuntu-latest]

37+ ghc:

38+ - ghc8.10

39+ - ghc8.8

40+ - ghc8.6

41+ include:

42+ - os: macos-latest

43+ ghc: ghc8.10

44+ env:

45+ STACK_YAML: stack.${{ matrix.ghc }}.yaml

46+ steps:

47+ - uses: actions/checkout@v2

48+ - name: Cache

49+ uses: actions/cache@v1

50+ with:

51+ path: ~/.stack

52+ key: ${{ runner.os }}-build-stack-${{ matrix.ghc }}-${{ hashFiles(env.STACK_YAML) }}-${{ hashFiles('**/*.cabal') }}

53+ restore-keys: |

54+ ${{ runner.os }}-build-stack-${{ matrix.ghc }}-${{ hashFiles(env.STACK_YAML) }}

55+ ${{ runner.os }}-build-stack-${{ matrix.ghc }}

56+ - name: Fix macOS cache bug

57+ run: rm -rf ~/.stack/setup-exe-cache

58+ - name: Build

59+ run: stack build --ghc-options -O2 --local-bin-path out --copy-bins

60+ - name: Test

61+ run: stack test --stack-yaml=${{ env.STACK_YAML }}

62+ - name: HLint

63+ run: curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s .

64+ - name: Haddock

65+ run: stack --no-install-ghc --system-ghc --no-haddock-deps haddock

66+ - uses: actions/upload-artifact@v2

67+ with:

68+ name: project-m36-${{ matrix.os }}-${{ matrix.ghc }}

69+ path: out/

.gitignore+3−1

@@ -18,4 +18,6 @@ persistence-notes

1818jupyter/itutd.egg-info

1919jupyter/build

2020juyter/dist

21−.ipynb_checkpoints

21+.ipynb_checkpoints

22+project-m36.nix

23+stack.yaml

.travis.ymldeleted−60

@@ -1,60 +0,0 @@

1−# For more information, see https://github.com/ChrisPenner/haskell-stack-travis-ci

2−language: c

3−sudo: false

4−

5−git:

6− submodules: false # whether to recursively clone submodules

7−

8−cache:

9− directories:

10− - $HOME/.ghc

11− - $HOME/.cabal

12− - $HOME/.stack

13− - .stack-work

14− timeout: 1000

15−

16−matrix:

17− fast_finish: true

18− include:

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

20− compiler: ": #stack 8.2.2"

21−

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

23− os: osx

24− os_image: xcode7.3

25− compiler: ": #stack 8.2.2"

26−

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

28− compiler: ": #stack 8.4.3"

29−

30−before_script:

31− - unset CC

32− - export PATH=$HOME/.local/bin:/opt/ghc/$GHC_VERSION/bin:$PATH

33− - ./.travis/install-ghr.sh

34− - ./.travis/install-stack.sh

35−

36−# Here starts the actual work to be performed for the package under test;

37−# any command which exits with a non-zero exit code causes the build to fail.

38−script:

39− - |

40− # Run tests

41− set -e

42− ./.travis/install-dependencies.sh

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

44− - |

45− #Run HLint

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

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

48− fi

49− - |

50− #Run Haddock

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

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

53− fi

54−

55−after_success:

56− - |

57− # Build and ship binary

58− #./.travis/attach-binary.sh

59−

60−# EOF

.travis/attach-binary.shdeleted−25

@@ -1,25 +0,0 @@

1−#!/bin/sh

2−set -o errexit -o verbose

3−

4−if test ! "$BUILD_BINARY" || test ! "$TRAVIS_TAG"

5−then

6− echo 'This is not a release build.'

7−elif test ! "$GITHUB_TOKEN"

8−then

9− echo 'The GITHUB_TOKEN environment variable is not set!'

10− exit 1

11−else

12− echo "Building binary for $TRAVIS_OS_NAME to $TRAVIS_TAG..."

13− stack build --ghc-options -O2 --pedantic

14− echo "Attaching binary for $TRAVIS_OS_NAME to $TRAVIS_TAG..."

15− OWNER="$(echo "$TRAVIS_REPO_SLUG" | cut -f1 -d/)"

16− REPO="$(echo "$TRAVIS_REPO_SLUG" | cut -f2 -d/)"

17− BIN="$(stack path --local-install-root)/bin/$REPO"

18− BUNDLE_NAME="$REPO-$TRAVIS_TAG-$TRAVIS_OS_NAME.tar.gz"

19− cp "$BIN" "./$REPO"

20− chmod +x "./$REPO"

21− tar -czf "$BUNDLE_NAME" "$REPO"

22− echo "SHA256:"

23− shasum -a 256 "$BUNDLE_NAME"

24− ghr -t "$GITHUB_TOKEN" -u "$OWNER" -r "$REPO" --replace "$(git describe --tags)" "$BUNDLE_NAME"

25−fi

.travis/install-dependencies.shdeleted−22

@@ -1,22 +0,0 @@

1−# Run tests

2−if [[ "$(uname)" = "Darwin" ]]; then

3− timeout_cmd="gtimeout"

4−else

5− timeout_cmd="timeout"

6−fi

7−$timeout_cmd 40m stack --no-terminal --jobs=2 --install-ghc --system-ghc build --only-dependencies --fast

8−ret=$?

9−case "$ret" in

10− 0)

11− # continue

12− ;;

13− 124)

14− echo "Timed out while installing dependencies."

15− echo "Try building again by pushing a new commit."

16− exit 1

17− ;;

18− *)

19− echo "Failed to install dependencies; stack exited with $ret"

20− exit "$ret"

21− ;;

22−esac

.travis/install-ghc.shdeleted−16

@@ -1,16 +0,0 @@

1−#!/bin/sh

2−set -eux

3−#assume stack is installed

4−STACK=~/.local/bin/stack

5−

6−fetch_ghc_osx() {

7− echo "Using stack to install GHC $GHC_VERSION"

8− $STACK setup $GHC_VERSION

9−}

10−

11−if [ "$(uname)" = "Darwin" ]; then

12− fetch_ghc_osx

13−else

14− #installed by apt

15− echo "Linux GHC $GHC_VERSION via APT already installed."

16−fi

.travis/install-ghr.shdeleted−21

@@ -1,21 +0,0 @@

1−#!/bin/sh

2−set -o errexit -o verbose

3−

4−if test ! "$BUILD_BINARY" || test ! "$TRAVIS_TAG"

5−then

6− echo 'This is not a release build.'

7−else

8− if [ "$TRAVIS_OS_NAME" = "linux" ]

9− then

10− ARCH="linux"

11− else

12− ARCH="darwin"

13− fi

14− echo "Installing ghr"

15− URL="https://github.com/tcnksm/ghr/releases/download/v0.5.4/ghr_v0.5.4_${ARCH}_386.zip"

16− curl -L ${URL} > ghr.zip

17− mkdir -p "$HOME/bin"

18− export PATH="$HOME/bin:$PATH"

19− unzip ghr.zip -d "$HOME/bin"

20− rm ghr.zip

21−fi

.travis/install-stack.shdeleted−27

@@ -1,27 +0,0 @@

1−#!/bin/sh

2−

3−# Adapted from https://github.com/commercialhaskell/stack

4−

5−set -eux

6−

7−travis_retry() {

8− cmd=$*

9− $cmd || (sleep 2 && $cmd) || (sleep 10 && $cmd)

10−}

11−

12−fetch_stack_osx() {

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

14−}

15−

16−fetch_stack_linux() {

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

18−}

19−

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

21−# builds.

22−mkdir -p ~/.local/bin;

23−if [ "$(uname)" = "Darwin" ]; then

24− travis_retry fetch_stack_osx

25−else

26− travis_retry fetch_stack_linux

27−fi

Changelog.markdown+33

@@ -1,3 +1,36 @@

1+# 2021-04-01 (v0.9.3)

3+* add new ":importtutd <URI> <SHA256 hash>" feature to import TutorialD from a local file or a HTTP/HTTPS URI

5+# 2020-12-27 (v0.9.0)

7+* replace unmaintained distributed-process-client-server RPC package with new curryer RPC package

8+* drop support for GHC 8.2 and GHC 8.4 due to dependency on DerivingVia extension

10+# 2020-11-21 (v0.8.2)

11+

12+* support multiple extend expressions in TutorialD

13+* fix parsing of Bool atoms in TutorialD

14+* fix database context expressions which include self-references such as `s:=s union s`

15+* show constraints as TutorialD when using tutd console

16+* add `RelationalExprAtom` data type useful for storing `RelationalExpr` within the database

17+

18+# 2020-10-05 (v0.8.1)

19+

20+* support GHC 8.10

21+

22+# 2020-05-25 (v0.8)

23+

24+* refactor backend to maximize laziness: [An Architecture for Data Independence](docs/data_independence.markdown)

25+

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

27+

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

29+* fix multibyte escaping in data frames

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

31+* fix `TypeConstructor` validation of argument count

32+* add help option to executables

33+

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

235

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

README.markdown+12−3

@@ -4,8 +4,8 @@

44[![Public Domain](https://img.shields.io/badge/license-Public%20Domain-brightgreen.svg)](http://unlicense.org)

55[![Hackage](https://img.shields.io/hackage/v/project-m36.svg)](http://hackage.haskell.org/package/project-m36)

66[![Hackage dependency status](https://img.shields.io/hackage-deps/v/project-m36.svg)](http://packdeps.haskellers.com/feed?needle=project-m36)

7−[![Build status](https://travis-ci.org/agentm/project-m36.svg?branch=master)](https://travis-ci.org/agentm/project-m36)

87[![Windows Build status](https://ci.appveyor.com/api/projects/status/q7jyddd6dy1ibqdo/branch/master?svg=true)](https://ci.appveyor.com/project/agentm/project-m36)

8+[![Github Workflow status](https://github.com/agentm/project-m36/workflows/CI/badge.svg)](https://github.com/agentm/project-m36/actions?query=workflow%3ACI)

1010

1111*Software can always be made faster, but rarely can it be made more correct.*

@@ -14,6 +14,12 @@

1414

1515Project:M36 implements a relational algebra engine as inspired by the writings of Chris Date.

1616

17+## Quick Install

18+

19+Project:M36 can be downloaded and run via docker, which supports Windows 10, macOS, and Linux.

20+

21+Run `docker run -it projectm36/project-m36 tutd` to start the TutorialD command line interface.

22+

1723## Description

1824

1925Unlike most database management systems (DBMS), Project:M36 is opinionated software which adheres strictly to the mathematics of the relational algebra. The purpose of this adherence is to prove that software which implements mathematically-sound design principles reaps benefits in the form of code clarity, consistency, performance, and future-proofing.

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

3844

3945* [Developer's Blog](https://agentm.github.io/project-m36/)

4046* [Mailing List/Discussion Group](https://groups.google.com/d/forum/project-m36)

41−* IRC Channel: chat.freenode.net #project-m36

47+* IRC Channel: irc.libera.chat #project-m36 -- [Chat via Web Client](http://kiwiirc.com/nextclient/irc.libera.chat:+6697/#project-m36)

4248* [Hackage](https://hackage.haskell.org/package/project-m36)

4349* [Diogo Biazus' Project:M36 Video Tutorial](https://www.youtube.com/watch?v=_GC_lxlVEnE)

4450

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

4854

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

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

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

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

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

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

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

60671. [ACID Database Properties](docs/acid_assessment.markdown)

61681. [On NULL (in SQL)](docs/on_null.markdown)

62691. [Reaching "Out of the Tarpit" with Project:M36](docs/reaching_out_of_the_tarpit.markdown)

70+1. [An Architecture for Data Independence](docs/data_independence.markdown)

6371

6472### Advanced Features

6573

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

76841. [Isomorphic Schemas](docs/isomorphic_schemas.markdown)

77851. [Replication](docs/replication.markdown)

78861. [Basic Operator Benchmarks](https://rawgit.com/agentm/project-m36/master/docs/basic_benchmarks.html)

87+1. [Merkle Transaction Hashes](docs/merkle_transaction_graph.markdown)

7988

8089### Integrations

8190

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

8594

8695## Development

8796

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

97+Project:M36 is developed in Haskell and compiled with GHC 8.6 or later.

8998

9099## Related Projects

91100

cabal.project+9−2

@@ -1,3 +1,10 @@

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

21packages: project-m36.cabal

3−allow-newer: distributed-process-extras:time,distributed-process-extras:binary,distributed-process-client-server:binary,distributed-process-client-server:time,distributed-process-async:time,distributed-process-async:binary

3+package *

4+ split-sections: True

6+--high-performance streaming library

7+source-repository-package

8+ type: git

9+ location: https://github.com/composewell/streamly.git

10+ tag: ac3af8749194f1788704dda8667d0b3807075cc2

default.nixnew file+1

@@ -0,0 +1 @@

1+(import ./release.nix { }).project

docker.nixnew file+18

@@ -0,0 +1,18 @@

1+{ compiler ? "ghc8104"

2+, sources ? import ./nix/sources.nix

3+, pkgs ? import sources.nixpkgs { }

4+}:

5+let

6+ release = import ./release.nix { inherit pkgs compiler sources; };

7+ static-project-m36 = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.justStaticExecutables release.project);

8+in

9+pkgs.dockerTools.buildImage {

10+ name = "project-m36";

11+ tag = "latest";

12+ contents = [ static-project-m36 ];

13+ # expose default project-m36 and websocket server ports

14+ config = {

15+ Env = [ "LC_ALL=en_US.UTF-8" ];

16+ ExposedPorts = { "6543/tcp" = { }; "8000/tcp" = { }; };

17+ };

18+}

docs/15_minute_tutorial.markdown+65−68

@@ -4,40 +4,34 @@ Thank you for evaluating Project:M36, a new relational algebra engine written in

55## Prerequisites

7−* any Linux

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

9−* cabal (package downloader) installed

7+* any Linux, MacOS, or Windows computer with Docker installed

108

119## Download and Install

1210

11+Run a pre-built docker image:

12+

13+```docker run -it projectm36/project-m36 tutd```

14+

15+or build it yourself with GHC >= 8.6:

16+

1317```bash

1418git clone https://github.com/agentm/project-m36.git

15−cabal sandbox init

16−cabal install --dependencies-only

17−cabal run tutd

19+cabal new-run tutd

1820```

1921

2022## Some Basic TutorialD

2123

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

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

2325

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

2527

2628### Load the Canonical Chris Date Example

2729

2830```

29−TutorialD (master/main): :importexample date

30−```

31−

32−or

33−

34−```

35−TutorialD (master/main): :importtud "scripts/DateExamples.tutd"

31+TutorialD (master/main): :importexample cjdate

3632```

3733

38−```:importtutd``` (do not skip typing the preceding colon), loads a file which contains a script written in the TutorialD dialect used by Project:M36 and executes it to change the state of the database. In this case, the relations "s" (supplier), "p" (product), and "sp" (suppliers-products) are now loaded.

39−

40−```:importexample date``` loads the date example directly without any file I/O, so it is safe to use with the websocket server.

34+```:importexample``` (do not skip typing the preceding colon), loads a built-in example schema and executes it to change the state of the database. In this case, the relations "s" (supplier), "p" (product), and "sp" (suppliers-products) are now loaded.

4135

4236### Execute Relational Expressions

4337

@@ -164,7 +158,7 @@ Database context expressions change the state of the database, much like "CREATE

164158#### Create a Relation Variable

165159

166160```

167−TutorialD (master/main): x:=relation{name Text, age Int}{tuple{name "Steve", age 40},tuple{name "Mike", age 31}}

161+TutorialD (master/main): x:=relation{name Text, age Integer}{tuple{name "Steve", age 40},tuple{name "Mike", age 31}}

168162TutorialD (master/main): :showexpr x

169163┌────────┬──────────┐

170164│age::Int│name::Text│

@@ -179,23 +173,25 @@ This is similar to SQL's "CREATE TABLE" operator.

179173#### Insert Additional Tuples

180174

181175```

182−TutorialD (master/main): x:=relation{name Text, age Int}{tuple{name "Steve", age 40},tuple{name "Mike", age 31}}

176+TutorialD (master/main): x:=relation{name Text, age Integer}{tuple{name "Steve", age 40},tuple{name "Mike", age 31}}

183177TutorialD (master/main): :showexpr x

184−┌────────┬──────────┐

185−│age::Int│name::Text│

186−├────────┼──────────┤

187−│40 │"Steve" │

188−│31 │"Mike" │

189−└────────┴──────────┘

178+┌────────────┬──────────┐

179+│age::Integer│name::Text│

180+├────────────┼──────────┤

181+│31 │"Mike" │

182+│40 │"Steve" │

183+└────────────┴──────────┘

184+

190185TutorialD (master/main): insert x relation{tuple{name "Bob", age 24}}

191186TutorialD (master/main): :showexpr x

192−┌────────┬──────────┐

193−│age::Int│name::Text│

194−├────────┼──────────┤

195−│40 │"Steve" │

196−│24 │"Bob" │

197−│31 │"Mike" │

198−└────────┴──────────┘

187+┌────────────┬──────────┐

188+│age::Integer│name::Text│

189+├────────────┼──────────┤

190+│31 │"Mike" │

191+│40 │"Steve" │

192+│24 │"Bob" │

193+└────────────┴──────────┘

194+

199195```

200196

201197Note that the relational insertion is identical to "x:=x union relation{...}".

@@ -204,50 +200,51 @@ Note that the relational insertion is identical to "x:=x union relation{...}".

204200

205201```

206202TutorialD (master/main): :showexpr s

207−┌──────────┬────────┬───────────┬───────────┐

208−│city::Text│s#::Text│sname::Text│status::Int│

209−├──────────┼────────┼───────────┼───────────┤

210−│"Paris" │"S2" │"Jones" │10 │

211−│"Paris" │"S3" │"Blake" │30 │

212−│"London" │"S1" │"Smith" │20 │

213−│"London" │"S4" │"Clark" │20 │

214−│"Athens" │"S5" │"Adams" │30 │

215−└──────────┴────────┴───────────┴───────────┘

203+┌──────────┬────────┬───────────┬───────────────┐

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

205+├──────────┼────────┼───────────┼───────────────┤

206+│"London" │"S1" │"Smith" │20 │

207+│"Athens" │"S5" │"Adams" │30 │

208+│"Paris" │"S3" │"Blake" │30 │

209+│"London" │"S4" │"Clark" │20 │

210+│"Paris" │"S2" │"Jones" │10 │

211+└──────────┴────────┴───────────┴───────────────┘

216212TutorialD (master/main): update s where city="London" (status:=35)

217213TutorialD (master/main): :showexpr s

218−┌──────────┬────────┬───────────┬───────────┐

219−│city::Text│s#::Text│sname::Text│status::Int│

220−├──────────┼────────┼───────────┼───────────┤

221−│"London" │"S4" │"Clark" │35 │

222−│"London" │"S1" │"Smith" │35 │

223−│"Paris" │"S2" │"Jones" │10 │

224−│"Paris" │"S3" │"Blake" │30 │

225−│"Athens" │"S5" │"Adams" │30 │

226−└──────────┴────────┴───────────┴───────────┘

214+┌──────────┬────────┬───────────┬───────────────┐

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

216+├──────────┼────────┼───────────┼───────────────┤

217+│"Athens" │"S5" │"Adams" │30 │

218+│"London" │"S1" │"Smith" │35 │

219+│"London" │"S4" │"Clark" │35 │

220+│"Paris" │"S3" │"Blake" │30 │

221+│"Paris" │"S2" │"Jones" │10 │

222+└──────────┴────────┴───────────┴───────────────┘

223+

227224```

228225#### Deleting Tuples from a Relation Variable

229226

230227```

231228TutorialD (master/main): :showexpr s

232−┌──────────┬────────┬───────────┬───────────┐

233−│city::Text│s#::Text│sname::Text│status::Int│

234−├──────────┼────────┼───────────┼───────────┤

235−│"Paris" │"S2" │"Jones" │10 │

236−│"Paris" │"S3" │"Blake" │30 │

237−│"London" │"S1" │"Smith" │20 │

238−│"London" │"S4" │"Clark" │20 │

239−│"Athens" │"S5" │"Adams" │30 │

240−└──────────┴────────┴───────────┴───────────┘

229+┌──────────┬────────┬───────────┬───────────────┐

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

231+├──────────┼────────┼───────────┼───────────────┤

232+│"Paris" │"S2" │"Jones" │10 │

233+│"Paris" │"S3" │"Blake" │30 │

234+│"London" │"S1" │"Smith" │20 │

235+│"Athens" │"S5" │"Adams" │30 │

236+│"London" │"S4" │"Clark" │20 │

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

241238TutorialD (master/main): delete s where sname="Adams"

242239TutorialD (master/main): :showexpr s

243−┌──────────┬────────┬───────────┬───────────┐

244−│city::Text│s#::Text│sname::Text│status::Int│

245−├──────────┼────────┼───────────┼───────────┤

246−│"Paris" │"S2" │"Jones" │10 │

247−│"Paris" │"S3" │"Blake" │30 │

248−│"London" │"S1" │"Smith" │20 │

249−│"London" │"S4" │"Clark" │20 │

250−└──────────┴────────┴───────────┴───────────┘

240+┌──────────┬────────┬───────────┬───────────────┐

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

242+├──────────┼────────┼───────────┼───────────────┤

243+│"Paris" │"S2" │"Jones" │10 │

244+│"London" │"S4" │"Clark" │20 │

245+│"Paris" │"S3" │"Blake" │30 │

246+│"London" │"S1" │"Smith" │20 │

247+└──────────┴────────┴───────────┴───────────────┘

251248```

252249

253250### Execute Transaction Graph Expressions

@@ -270,7 +267,7 @@ TutorialD (master/main): :rollback

270267

271268```

272269TutorialD (master/main): :branch experimental

273−TutorialD (experimental): employee:=relation{name Text, salary Int}

270+TutorialD (experimental): employee:=relation{name Text, salary Integer}

274271TutorialD (experimental): :commit

275272```

276273

docs/commits_in_constant_time.markdownnew file+134

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

1+# Transactional Database Commits in O(1)

3+A.M.

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

7+## Synopsis

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

10+

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

12+

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

14+

15+## Rationale

16+

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

18+

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

20+

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

22+

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

24+

25+## Example and Comparison to PostgreSQL

26+

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

28+

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

30+

31+

32+### The Update Expression

33+

34+Consider the following database update:

35+

36+```

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

38+```

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

40+

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

42+

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

44+

45+### The Commit

46+

47+```

48+COMMIT;

49+```

50+

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

52+

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

54+

55+### The Subsequent Query

56+

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

58+

59+```

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

61+```

62+

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

64+

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

66+

67+```

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

69+```

70+

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

72+

73+### Summary

74+

75+| | PostgreSQL | Project:M36 |

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

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

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

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

80+

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

82+

83+## Constraint Oracles

84+

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

86+

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

88+

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

90+

91+## Worst Case Behavior

92+

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

94+

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

96+

97+## Caveats

98+

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

100+

101+```

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

103+```

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

105+

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

107+

108+## Applying Laziness to SQL RDBMSes

109+

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

111+

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

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

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

115+

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

117+

118+## Benchmarks

119+

120+Forthcoming.

121+

122+## Conclusion

123+

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

125+

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

127+

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

129+

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

131+

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

133+

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

docs/data_independence.markdownnew file+109

@@ -0,0 +1,109 @@

1+# Project:M36: Towards an Architecture for Data Independence

3+## Introduction

5+The Project:M36 relational algebra architecture sets itself apart from typical DBMSes by ensuring strict transactional isolation, a branchable/mergeable (rather than linear) transaction graph, and storage of relational expressions (rather than storage of tuples). Let's look at how these architectural features work together to make Project:M36 the first relational algebra engine to implement true data independence.

7+## What is Data Independence?

9+C.J. Date writes:

10+

11+`Certainly most SQL products have failed to live up to the [relational] model's full potential...in those products, what the user sees and what is physically stored are essentially the same thing... In particular, it accounts for the argument, so often heard, to the effect that we have to "denormalize for performance."`

12+

13+`In principle, logical design has absolutely nothing to do with performance at all.`

14+

15+(Date, C.J. "Database In Depth: Relational Theory for Practitioners". O'Reilly Media. 2005. pages 156-157.)

16+

17+Data independence is therefore defined as the separation of the database user's experience from the database's means of in-memory or on-disk representation. As Date points out, virtually all database products implement a one-to-one mapping of relations to files in storage.

18+

19+One advantage of high-level abstractions in programming languages is to leverage advanced algorithms which can choose optimization paths on behalf of the user which a human may never be able to discover. While the promise of ever higher-level abstractions is realized by progamming languages such as Haskell, DBMS implementors have been resistant to data independence. This is due to several legacy factors such as companies pushing one-trick-pony database technologies and middlemen such as DBAs required to play gatekeeper against "bad" schema changes. The result is customers forced to run multiple disparate databases such as one for realtime transaction processing and another for analytics and another for audit logging. This recalcitrance has also led to the rise of databases such as "document" JSON databases with weak mathematical underpinnings in the name of performance as users become frustrated when hitting performance walls and dealing with arbitrary database limitations.

20+

21+Implementations which closely tie the user interface to backend representation close the door on interesting alternative representations and optimizations. For example, SQL databases typically store a single relation as a list of tuples on disk with supplementary indexes stored in separate files. There is no reason that the same relation couldn't be on disk or in memory in any number of formats. Such a table might be useful in various formats ideal for servicing different types of queries. Data independence grants the DBMS the permission to create any number of representations- including none at all- as long as the correct answer is provided to the user. "Column-store" databases may try to slice the tuples in a different axis, but those databases simply shift the performance problems elsewhere. Only implementation details prevent a database from offering both column-oriented *and* tuple-oriented representation while allowing the database to choose.

22+

23+That is why it is critical for the user's interface to the database *not* to include features such as "query hints" which would force a specific implementation in the backend. The user's interface must be declarative (describing the state change or query rather than *how* to execute it) and sufficiently high level. Any implementation detail leakage to the user's interface is a lost potential algorithmic optimization. While the topic of providing high-level interfaces is not specific to database design, we will continue to explore the ramifications of data independence in databases.

24+

25+

26+## Transactional Isolation

27+

28+While other databases offer various transaction isolation levels with differing levels of implementation-specific surprises, Project:M36 solely suppports the maximum transaction isolation level. Instead of relying on details of [MVCC](https://www.postgresql.org/docs/current/mvcc-intro.html) which marks each tuple in a relation with a monotonically-increasing number identifying from which transaction the tuple was added or deleted, Project:M36 includes no singular backing store for tuples, instead storing a stream of state change requests. Because the transaction graph supports branching and merging (similar to version control such as git), transactions can be committed without contention at a singular head of the graph. Committing to disk can be implemented as writing a file to represent the transaction's state and

29+

30+## The Transaction Graph

31+

32+These state changes are, in fact, the idempotent relational update expressions that the user has submitted. For example, given a transaction which includes a single relation `s`:

33+

34+```

35+┌──────────┬────────┬───────────┬───────────┐

36+│city::Text│s#::Text│sname::Text│status::Int│

37+├──────────┼────────┼───────────┼───────────┤

38+│"Paris" │"S2" │"Jones" │10 │

39+└──────────┴────────┴───────────┴───────────┘

40+```

41+

42+if the user commits a transaction with an insert such as:

43+

44+```

45+insert x relation{tuple{city "Boston", s# "S3", sname "Smith", status 400}}

46+```

47+

48+then a typical database will find the file representing the relation, find some free space in it and save the new tuple along with the MVCC transaction identifier. Subsequent transactions will find the tuple and compare it to their own transaction id in order to determine its "visibility". Project:M36, on the other hand, after validating that all relational constraints (such as primary and foreign keys) still hold, will simply serialize and append the expression to the transaction graph log. By default, there is no file representing the relation.

49+

50+For those familiar with Haskell, note how serializing the update expression is similar to being able to serialize a thunk or deferred execution.

51+

52+The transaction graph also allows users to travel back to previously-committed transactions. This may be useful for audit logging or alternative schemas.

53+

54+## Storage Representations

55+

56+Given the ever-growing transaction graph based on state changes, let's examine how Project:M36 services subsequent queries.

57+

58+## Benefits

59+

60+The primary goal of a database should be to ensure data integrity. Project:M36 takes no shortcuts in achieving this goal, but choosing a backend architecture which minimizes the time which it takes to get the transaction to non-volatile storage (disk) by storing update expressions rather than attempting to shuffle tuples on disk. This architecture open the door to many optimization techniques, many of which are new to databases.

61+

62+### Multiple On-Disk Representations

63+

64+The promise of data independence allows database backends to store relations as they see fit. That can include any number of on-disk representations including none at all. For example, for a table accessed by multiple projections, the database may choose to materialize the relation in those projections. The representations are therefore created in service to the queries submitted or anticipated instead of being based on past update expressions. Because on-disk storage is obviously limited, the database must decide what is valuable to keep around for future queries. This could open a new area of research into the appropriate machine learning algorithms, but, fundamentally, this set of materialized query responses is effectively a cache which can always be refreshed.

65+

66+The alternative representations need not be a direct answer to queries- for example, a materialized relation from a transaction could be used to service a query from a later transaction if the updates since that transaction are applied.

67+

68+The database could also anticipate, for example, scheduled queries and actually materialize relations before the query is executed. On-disk cache could represent "denormalized" tuple sets while the user-facing interface shows a properly normalized schema, thereby supporting data independence.

69+

70+More research in determining just what should be in the cache is needed.

71+

72+### Transactional Commits in O(1) Time

73+

74+Because the Project:M36 backend need not save tuples into a specific file representing a relation, the backend can drastically reduce the amount of time needed to commit a transaction to disk. Specifically, following constraint validation (which can often be done in constant or logarithmic time relative to the tuple count), the fastest means of committing the transaction is to save the update expression itself. Since the previous state has already been presumably committed, any idempotent operation can be saved for deferred execution. This means that transactions can be committed to disk relative to the size of the update expression rather than the number of the tuples affected- committing can occur at a rate relative to that of update expression size (typically a few kilobytes) rather than relative to the number of tuples that the update expression happened to alter.

75+

76+This technique gets transactions to disk faster, thus drastically increasing the rate transactions can be committed overall. Note that the execution of the update expression may be deferred by this process, so the cost to evaluate it may occur later, but this processing may be performed in the background after the transaction is committed. When the data is never requested, for example, for a defunct transaction graph branch, the actual execution could be deferred indefinitely, incurring zero cost to calculate the consquence of the update.

77+

78+### Less Disk Usage

79+

80+Because Project:M36 stores a stream of update expressions rather than tuples themselves, the minimum storage requirements for a given database may be reduced. For example, if a relation with an attribute `x` of type `Integer` has 1,000,000 tuples, a subsequent update to increment all 1,000,000 values by one may be cheaper to evaluate on-demand rather than immediately generating 1,000,000 new tuples and saving them to disk. If the new tuples are requested, the database can determine that the tuples are not materialized, calculate them, and return them, all without ever having the tuples on disk. Furthermore, if only a subset of the tuples are ever requested, for example, due to a query restriction, then some of the tuples may never need to be calculated or materialized.

81+

82+### Audit Logging

83+

84+Typical databases implement various strategies for audit logging, including:

85+

86+* exposing MVCC-like values such as tuple "created at" and "created by" to the user and forcing all tables to be insert-only

87+* shuttling audit logs to a secondary database

88+

89+Project:M36, through its inherent ability to travel the append-only transaction graph, enables audit-logging by allowing users to checkout previous transaction states. Committed transaction states are immutable, so no relation pollution or secondary database is necessary.

90+

91+### Selective Caching

92+

93+Typical databases materialize entire tuple sets representing each named relation (relation variable), but there is nothing special about relations that happen to be named. Data independence allows us to cache answers to common or even anticipated queries- this allows the schema to be normalized and unmaterialized while the *denormalized* query results are materialized cached. This flexibility saves disk space and allows the cache to be much more dynamic than in a typical DBMS.

94+

95+### Never-Materialized Tuples Replace Partitions

96+

97+Queries on very large relations often very often restricted (filtered by tuple) to generate subsets which are often partitioned, for example, by an event's date. Instead of requiring DBMS users to manually partition and slice their data in one, fixed, particular way, Project:M36's cacheing system will only cache those tuples that serve the interests of the queries. With something like an LRU cache, a data independent architecture will naturally cache "partitions" of the full relation without manual intervention.

98+

99+### Elimination of DBA role

100+

101+Databases essential to a business function are often guarded by a human database administrator (DBA) whose role it is to monitor database performance and to play gatekeeper to database schema changes as the database grows. This role is necessary because database tuning can be an arcane skill, rife with pitfalls for those who don't know the database software inside-and-out. This is a direct cause of data dependence, forcing DBAs to manually enforce data partitioning and shuffling data to different servers, configuring database replicas, and making Faustian bargains to "denormalize" tables for analytical workloads.

102+

103+A data independent architecture eliminates this role by allowing the database to make the optimal choices itself. This means that the database can respond to schema changes immediately, without manual repartitioning or denormalization steps.

104+

105+## Conclusion

106+

107+Project:M36's backend architecture enables new optimizations and features that are sorely lacking in existing DBMSes. By leveraging its novel transaction graph and deferred evaluation, Project:M36 handles more DBMS use-cases.

108+

109+Project:M36's novel architecture opens the door for further database and algorithmic research.

docs/filesystem-persistence.markdown+1−1

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

1−# Project-M36 Filesystem Persistence

1+# Project-M36 Filesystem Persistence (Change Proposal)

33## Introduction

docs/import_export_csv.markdown+2−2

@@ -9,7 +9,7 @@ If a relation variable cannot be exported due to data types which are not suppor

99### Example Export

1010

1111```

12−TutorialD (master/main): :importexample date

12+TutorialD (master/main): :importexample cjdate

1313TutorialD (master/main): :exportcsv s "/tmp/csv"

1414```

1515```

@@ -37,7 +37,7 @@ s#,sname,status,city

3737S6,Samson,100,New York

3838```

3939```

40−TutorialD (master/main): :importexample date

40+TutorialD (master/main): :importexample cjdate

4141TutorialD (master/main): :showexpr s

4242┌──────────┬────────┬───────────┬───────────────┐

4343│city::Text│s#::Text│sname::Text│status::Integer│

docs/introduction_to_projectm36.markdown+28−9

@@ -15,16 +15,35 @@ The relational algebra is the mathematical model underpinning Project:M36. When

1515

1616## Binary Releases

1717

18−### Windows

19−Project:M36 now provides binary installations for Windows. Check the (releases page)[https://github.com/agentm/project-m36/releases] for downloads.

18+The quickest and preferred method of installation is via docker, which works on Linux, macOS, and Windows. Docker downloads and runs preconfigured software in secure, sandboxed containers, preventing third-party software from altering the host system without your permission.

2019

21−### MacOS X

20+### Install Docker:

2221

23−Binary releases are not yet available for MacOS X, but compiling from source is easy.

22+* [Windows 10 Docker Installation](https://docs.docker.com/docker-for-windows/wsl/)

23+* [MacOS Docker Installation](https://docs.docker.com/docker-for-mac/install/)

24+* [Linux Docker Installation](https://docs.docker.com/engine/install/#server)

2425

25−### Linux

26+### Run TutorialD from Docker Image

2627

27−The currently-preferred method of installation is from source. A future enhancement would be installation from deb or rpm.

28+This downloads the docker image tagged "latest" and runs `tutd`, the TutorialD command line interface. Try the [15-Minute TutorialD Tutorial](15_minute_tutorial.markdown) and try some expressions.

29+

30+```bash

31+docker run -it projectm36/project-m36 tutd

32+```

33+

34+### Run Project:M36 Server

35+

36+The default port for the project-m36 server is 6543.

37+

38+```bash

39+docker run --network host projectm36/project-m36 project-m36-server -n <database_name>

40+```

41+

42+### Connect to Project:M36 Server

43+

44+```bash

45+docker run --network host projectm36/project-m36

46+```

2847

2948## Source Installation

3049

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

3251

3352To build with stack:

3453

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

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

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

3756* Linux, macOS, or Microsoft Windows

3857

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

4059

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

4261* ```cd project-m36```

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

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

4463

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

4665

47−Alternative building with GHC 8.0.2 or greater:

66+Alternative building with GHC 8.6.5 or greater:

4867

4968* ```cabal new-build```

5069

docs/introduction_to_the_relational_algebra.markdown+2−2

@@ -202,7 +202,7 @@ Join (Instructor relation)

202202

203203(Course Relation)

204204

205−|(Course Name, Course Name Type)|(Instructor, Instructor Name Type)|(Course Room Number, Room Number Type)|

205+|(Course Name, Course Name Type)|(Instructor Name, Instructor Name Type)|(Course Room Number, Room Number Type)|

206206|-------------------------------|----------------------------------|--------------------------------------|

207207|English 1|Steve|Room 104|

208208|French 2|Bob|Room 103|

@@ -378,7 +378,7 @@ Since a value can store any (immutable) type, it can certainly hold a relation.

378378

379379For example, in SQL, if one wants to collect some aggregate data over some tuples while still returning the individual tuples, in the best case, the aggregate information must be repeated for every individual tuple. In the worst case, two separate queries are required since nested tables are not supported.

380380

381−In the relational algebra, The aggregate value can be placed alongside the relation value from whic the aggregate was derived.

381+In the relational algebra, The aggregate value can be placed alongside the relation value from which the aggregate was derived.

382382

383383Example:

384384

docs/merkle_transaction_graph.markdownnew file+33

@@ -0,0 +1,33 @@

1+# Project:M36: Merkle Hashing for Transaction Graph

3+## Introduction

5+Project:M36 supports an append-only transaction graph model (similar to git) whereby new transactions can be added to the graph but not removed. As with any graph, each node can contain a Merkle hash which ensures not only that it's state since being added to the graph has not changed but also that none of its parent nodes all the way to the root node (initial state) have not been modified. This validation has a number of use cases.

7+## Usage

9+Project:M36 automatically adds Merkle hashes to every transaction. All data which represents the database state at that transaction is included in the hash including (but not limited to) relation variable definitions, atom and database context functions, constraints, and types.

10+

11+Project:M36 validates all merkle hashes at database startup. For users who need validation after the database is started, the user can issue `:validatemerklehashes` at the `tutd` command line.

12+

13+### Audit Logging

14+

15+Project:M36 supports audit logging by allowing users to travel to transactions in the past and recreate the database state at that past point-in-time. To ensure that those past states cannot be modified either by malicious on-disk or in-memory changes, each transaction is protected by its own Merkle hash. If the calculated hash does not match the stored hash, Project:M36 can immediately report which transaction triggered the tamper-proof log.

16+

17+### Reproducibility

18+

19+Since a Merkle tree is effectively immutable except to add more nodes, it can be used to save and restore a whole database with very high confidence in the results. This feature could also be used to restore a database partially; for example, to duplicate just the latest database state on a second machine for OLAP analysis.

20+

21+### High-Availability

22+

23+Merkle tree hashes can be used to assert database integrity across high-availibility or database replication. Since the hash covers all database state, it can be used to validate log-shipping-based replication. Corrupted cache tuple data can be easily detected and flushed.

24+

25+## Merkle Hashes in Other DBMSes

26+

27+While Merkle hashes have become prevalent in blockchain-style databases, they have not made many appearances in typical SQL databases. This is likely due to the fact that such databases consider any additional operations against the large tuple stores as prohibitively expensive. Project:M36 is able to skirt this cost by only hashing database update expressions rather than the result of these executed expressions. This also means that the Merkle hash can be computed against transactions which have been created but never executed.

28+

29+## Conclusion

30+

31+Merkle hashes are an obvious improvement to any graph-based transaction log and are a low-cost method of ensuring data integrity.

32+

33+A further improvement could allow users to specify an initial key provided by an admin user to salt the hash used to create the database. Additionally, a multi-user system could allow individual users to sign their committed transactions. The signature would then be included in the Merkle hash.

docs/reaching_out_of_the_tarpit.markdown+1−1

@@ -57,7 +57,7 @@ Project:M36 implements multiple interfaces:

5757To understand how Project:M36 stacks up against the fictional programming language shown in the paper, we have implemented the [example from the paper](/examples/out_of_the_tarpit.tutd). The language used in the script is a dialect of Chris Date's TutorialD language. It can be loaded into an interactive ```tutd``` session like so:

5858

5959```

60−TutorialD (master/main): :importexample date

60+TutorialD (master/main): :importexample cjdate

6161TutorialD (master/main): :showexpr p

6262┌───────────────────┬────────────┬───────────────────┬────────────┬────────────┐

6363│address::Address │agent::Agent│dateRegistered::Day│photo::Text │price::Price│

docs/server_mode.markdown+1−1

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

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

1010

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

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

1212

1313## Connecting an Interactive Client

1414

docs/transaction_graph_operators.markdown+6−4

@@ -43,15 +43,17 @@ TutorialD (master/main): :rollback

4343In order to navigate the transaction graph, one must specify transaction UUIDs. Viewing the entirety of the transaction graph as a relation is a single command.

4444

4545```

46−TutorialD (master/main): :showgraph

47−┌─────────────┬──────────┬──────────────────────────────────────┬────────────────────────────┬──────────────────────────────┐

48−│current::Bool│head::Text│id::Text │parents::relation {id::Text}│stamp::DateTime │

49−├─────────────┼──────────┼──────────────────────────────────────┼────────────────────────────┼──────────────────────────────┤

46+┌─────────────┬────────────────────────────────────────────┬──────────┬──────────────────────────────────────┬────────────────────────────────────────┬─────────────────────────────────┐

47+│current::Bool│hash::ByteString │head::Text│id::Text │parents::relation {id::Text} │stamp::DateTime │

48+├─────────────┼────────────────────────────────────────────┼──────────┼──────────────────────────────────────┼────────────────────────────────────────┼─────────────────────────────────┤

49+

5050

5151<big result elided>

5252```

5353The "current" attribute is a boolean value. If true, the transaction is the parent of the current database context. Commits will be children of this transaction.

5454

55+The "hash" attribute contains the merkle tree hash for the given transaction. This can be used to ensure that the transaction graph has been used in an append-only fashion, ensuring historical state and audit log integrity.

56+

5557The "head" attribute is a boolean value indicating whether or not the transaction is a "head" node of its graph. Head nodes are nodes which have no children.

5658

5759The "id" attribute is the UUID needed in order to navigate the graph.

docs/tupleable.markdown+19

@@ -23,6 +23,25 @@ instance Tupleable Person

2323

2424Now, ```Person``` values can be marshaled between the database and the client. The attribute names appearing in the Haskell data type will appear identically in the server with the same types.

2525

26+### Changing Options

27+

28+If our field names don't exactly match attribute names, but follow a common pattern, we can derive Tupleable with custom options. Let's say each field on person has a prefix "person", but we still want to use the attribute names without the prefix. We can make use of the ProjectM36.Tupleable module to accomplish our goal like so:

29+

30+```haskell

31+import ProjectM36.Tupleable.Deriving

32+

33+data Person = Person {

34+ personName :: Text,

35+ personEmployeeNumber :: Int,

36+ personLikesHorses :: Bool

37+ }

38+ deriving stock Generic

39+ deriving Tupleable

40+ via Codec (Field (DropPrefix "person" >>> CamelCase)) Person

41+```

42+

43+The extensions DerivingGeneric, DerivingVia, TypeOperators, and DataKinds must be enabled for this code to compile. See the documentation on Hackage for all available options.

44+

2645## Usage

2746

2847The ```Tupleable``` module includes the following functions:

docs/tutd_cheatsheet.markdownnew file+99

@@ -0,0 +1,99 @@

1+# Tutorial D Cheatsheet

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

5+## Relational Expressions

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

9+|Relational Expression |Description |

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

29+

30+## Built-In Types

31+

32+|Example Value Expression |Type |Explanation|

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

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

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

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

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

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

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

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

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

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

43+

44+## Database Context Expressions

45+

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

47+

48+|Database Context Expression |Description |

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

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

51+|`:importtutd "file:///home/agentm/project-m36/scripts/emp.tutd"`|Imports TutorialD from file URI|

52+|`:importtutd "https://raw.githubusercontent.com/agentm/project-m36/master/scripts/emp.tutd" "effe32b247586dc3ac0079fc241b9618d41d189afcaeb7907edbe5a8b45992a4"`| Imports TutorialD from HTTP or HTTPS URI|

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

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

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

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

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

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

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

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

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

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

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

65+

66+

67+## Transaction Graph Expressions

68+

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

70+

71+|Transaction Graph Expression |Description |

72+|------------------------------------------------------|---------------------------------------|

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

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

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

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

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

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

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

80+

81+## Data Frame Expressions

82+

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

84+

85+|Data Frame Expression |Description |

86+|------------------------------------------------------|---------------------------------------|

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

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

89+

90+## Trans-Graph Relational Expressions

91+

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

93+

94+|Trans-Graph Relational Expressions |Description |

95+|------------------------------------------------------|---------------------------------------|

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

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

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

99+

docs/tutd_tutorial.markdown+56−2

@@ -19,7 +19,7 @@ TutorialD (master/main):

1919The examples in this tutorial can be executed after loading Chris Date's sample relations using:

2020

2121```

22−:importexample date

22+:importexample cjdate

2323```

2424

2525Each section assumes a fresh instance of the Date examples. The relation variables created in the script are:

@@ -30,6 +30,24 @@ Each section assumes a fresh instance of the Date examples. The relation variabl

3030|p|parts|

3131|sp|contains mapping of which suppliers supply which parts|

3232

33+### Importing TutorialD from Other Sources

34+

35+The `tutd` console can also run TutorialD from a local file or from a web server.

36+

37+To import TutorialD from a file:

38+

39+```

40+:importtutd "file:///home/agentm/project-m36/scripts/emp.tutd"

41+```

42+

43+or from a web server:

44+

45+```

46+:importtutd "https://raw.githubusercontent.com/agentm/project-m36/master/scripts/DateExamples.tutd" "db9f3d9fe06d0a29b8355e045b89ec94d6428e3a3de93def7ca77bf0298b7010"

47+```

48+

49+The second argument is an optional SHA256 hash in hexadecimal form. This can be used to validate that the script has not changed since the last import. Importing TutorialD from the web is in general safe because it is effectively sandboxed with "Safe Haskell" for functions, so the script is contained security-wise, however, nothing prevents the script from running forever. Downloading a schema from the web is a great way to share schemas and to kick start your project without starting from scratch.

50+

3351### Types

3452

3553TutorialD is strongly-typed. The basic built-in types are:

@@ -197,7 +215,7 @@ TutorialD (master/main): :showexpr s{all but city}

197215└────────┴───────────┴───────────────┘

198216```

199217

200−Projection attributes can also be derived from a relational expression using `all from`:

218+Projection attributes can be derived from a relational expression using `all from`:

201219

202220```

203221TutorialD (master/main): :showexpr (s join sp){all from s}

@@ -213,6 +231,42 @@ TutorialD (master/main): :showexpr (s join sp){all from s}

213231

214232Above, we join `s` and `sp` but project the result back onto the attributes of `s`.

215233

234+Projection attributes can be unioned from multiple sources using `union of`:

235+

236+```

237+TutorialD (master/main): :showexpr (s join sp){union of {all from s} {all but p#}}

238+┌──────────┬────────────┬────────┬───────────┬───────────────┐

239+│city::Text│qty::Integer│s#::Text│sname::Text│status::Integer│

240+├──────────┼────────────┼────────┼───────────┼───────────────┤

241+│"Paris" │400 │"S2" │"Jones" │10 │

242+│"London" │400 │"S1" │"Smith" │20 │

243+│"Paris" │200 │"S3" │"Blake" │30 │

244+│"London" │200 │"S4" │"Clark" │20 │

245+│"London" │200 │"S1" │"Smith" │20 │

246+│"Paris" │300 │"S2" │"Jones" │10 │

247+│"London" │100 │"S1" │"Smith" │20 │

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

249+│"London" │300 │"S1" │"Smith" │20 │

250+│"London" │400 │"S4" │"Clark" │20 │

251+└──────────┴────────────┴────────┴───────────┴───────────────┘

252+```

253+

254+Here, after joining `s` and `p`, the union of all attributes from `s` and all attributes from `p` except for `p#` are returned.all

255+

256+Finally, projection attributes can be intersected using `intersection of`:

257+

258+```

259+TutorialD (master/main): :showexpr (s join sp){intersection of {all from s} {all from p}}

260+┌──────────┐

261+│city::Text│

262+├──────────┤

263+│"London" │

264+│"Paris" │

265+└──────────┘

266+```

267+

268+Here, after joining `s` and `p`, we project on the intersection of attributes from `s` and `p` which happens to be `city`.

269+

216270#### Restriction

217271

218272Restriction is applied using a "where" clause, much like in SQL.

docs/websocket_server.markdown+2−2

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

1616

1717## Client Connection

1818

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

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

2020

2121## Sample Application

2222

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

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

examples/DerivingCustomTupleable.hsnew file+54

@@ -0,0 +1,54 @@

1+{-# LANGUAGE DeriveGeneric, DerivingVia, GeneralizedNewtypeDeriving, TypeOperators, DataKinds, OverloadedStrings #-}

3+import ProjectM36.Tupleable.Deriving

4+import ProjectM36.Atomable (Atomable)

5+import Control.DeepSeq (NFData)

6+import Data.Text (Text)

7+import GHC.Generics (Generic)

8+import Codec.Winery

10+newtype BlogId = BlogId { getBlogId :: Int }

11+ deriving stock (Eq, Ord, Show, Generic)

12+ deriving newtype (Num)

13+ deriving Serialise via WineryRecord BlogId

14+

15+instance NFData BlogId

16+instance Atomable BlogId

17+

18+data Blog = Blog

19+ { blogId :: BlogId

20+ , blogTitle :: Text

21+ , blogAuthorName :: Text

22+ }

23+ deriving stock (Show, Generic)

24+ deriving (Tupleable)

25+ via Codec (Field (DropPrefix "blog" >>> CamelCase)) Blog

26+ deriving Serialise via WineryRecord Blog

27+

28+data Comment = Comment

29+ { commentAuthorName :: Text

30+ , commentComment :: Text

31+ , commentFor :: BlogId

32+ }

33+ deriving stock (Show, Generic)

34+ deriving (Tupleable)

35+ via Codec (Field (DropPrefix "comment" >>> CamelCase)) Comment

36+ deriving Serialise via WineryRecord Comment

37+

38+main :: IO ()

39+main = do

40+ let exampleBlog = Blog

41+ { blogId = 0

42+ , blogTitle = "Cat Pics"

43+ , blogAuthorName = "Alice"

44+ }

45+ exampleComment = Comment

46+ { commentAuthorName = "Bob"

47+ , commentComment = "great"

48+ , commentFor = 0

49+ }

50+ print exampleBlog

51+ print (toTuple exampleBlog)

52+ putStrLn ""

53+ print exampleComment

54+ print (toTuple exampleComment)

examples/Plantfarm.hsnew file+446

@@ -0,0 +1,446 @@

1+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE OverloadedStrings #-}

5+{-# LANGUAGE DeriveAnyClass #-}

7+{-# LANGUAGE DerivingVia #-}

10+import Codec.Winery (Serialise, WineryVariant(WineryVariant))

11+import Control.DeepSeq (NFData)

12+import Data.Aeson (FromJSON, ToJSON(toEncoding, toJSON))

13+import Data.Data (Proxy(Proxy))

14+import Data.Either (lefts, rights)

15+import Data.Functor (($>))

16+import Data.Text as T (Text)

17+import qualified Data.Text.Lazy as TL (pack)

18+import GHC.Generics (Generic)

19+import qualified ProjectM36.Base as Base

20+import ProjectM36.Client

21+ ( AtomExprBase(NakedAtomExpr)

22+ , Atomable(toAddTypeExpr, toAtom)

23+ , AttributeName

24+ , Connection

25+ , ConnectionInfo(InProcessConnectionInfo)

26+ , DatabaseContextExpr

27+ , DatabaseContextExprBase(Delete)

28+ , PersistenceStrategy(NoPersistence)

29+ , RelationalError

30+ , RelationalExprBase(RelationVariable, Restrict)

31+ , RestrictionPredicateExprBase(AttributeEqualityPredicate)

32+ , SessionId

33+ , close

34+ , commit

35+ , connectProjectM36

36+ , createSessionAtHead

37+ , databaseContextExprForUniqueKey

38+ , defaultHeadName

39+ , emptyNotificationCallback

40+ , executeDatabaseContextExpr

41+ , executeRelationalExpr

42+ , withTransaction

43+ )

44+import qualified ProjectM36.Relation as Relation

45+import ProjectM36.Tupleable

46+ ( Tupleable(fromTuple)

47+ , toDefineExpr

48+ , toDeleteExpr

49+ , toInsertExpr

50+ , toUpdateExpr

51+ )

52+import qualified System.Random as R

53+

54+

55+import Control.Monad.IO.Class (MonadIO(liftIO))

56+import qualified Web.Scotty as S

57+

58+-- | This is an example showcasing the updating of data

59+-- with the help of plants. \\

60+-- This is a very simple example and of course not how

61+-- plants grow in nature. \\

62+-- The main goal of this example is to showcase the updating

63+-- of data and the different options of persistence.

64+-- You can just pipe the output from curl into jq:

65+--

66+-- curl -X POST -H 'Accept: application/json' http://localhost:8001/plant/water/angu | jq -r '.stage'

67+

68+

69+data Stage = Seed | Sprout | Seedling | Adult | Dead

70+ deriving (Show, Eq, Ord, Generic, NFData, Atomable)

71+ deriving Serialise via WineryVariant Stage

72+

73+

74+instance ToJSON Stage where -- The where can be removed and the implementation commented out

75+ -- if the ascii values are not wanted

76+ toJSON s = toJSON $ show s <> "\nascii only provided for visualisation:\n" <> stagetoAscii s

77+

78+ toEncoding s = toEncoding $ show s <> "\nascii only provided for visualisation:\n" <> stagetoAscii s

79+

80+instance FromJSON Stage

81+

82+instance S.Parsable Stage where

83+ parseParam t

84+ | t == "seed" || t == "Seed" = Right Seed

85+ | t == "sprout" || t == "Sprout" = Right Sprout

86+ | t == "seedling" || t == "Seedling" = Right Seedling

87+ | t == "adult" || t == "Adult" = Right Adult

88+ | t == "dead" || t == "Dead" = Right Dead

89+ | otherwise = Left t

90+

91+

92+-- Just for ToJSON for ilustration of stage

93+type ASCIIStage = String

94+

95+seedStr :: ASCIIStage

96+seedStr = "<>\n\

97+ \'''\n"

98+sproutStr :: ASCIIStage

99+sproutStr = " ..\n\

100+ \<|>\n\

101+ \''''\n"

102+seedlingStr :: ASCIIStage

103+seedlingStr = " `\\⁄o \n\

104+ \ v|/\n\

105+ \'´;'''\n"

106+adultStr :: ASCIIStage

107+adultStr = "*~(#)~\n\

108+ \ \\,Y,e\n\

109+ \ \\|/\n\

110+ \''+'\\''\n"

111+deadStr :: ASCIIStage

112+deadStr = " ,__:<\n\

113+ \'/'''''\n"

114+

115+-- Just used for ToJSON illustration of stages

116+stagetoAscii :: Stage -> ASCIIStage

117+stagetoAscii Seed = seedStr

118+stagetoAscii Sprout = sproutStr

119+stagetoAscii Seedling = seedlingStr

120+stagetoAscii Adult = adultStr

121+stagetoAscii Dead = deadStr

122+

123+-- used for update stage

124+next :: Stage -> Stage

125+next Seed = Sprout

126+next Sprout = Seedling

127+next Seedling = Adult

128+next s = s

129+

130+data Plant = Plant { name :: Text, species :: Text, stage :: Stage, waterings:: Integer } deriving (Show, Generic)

131+instance Tupleable Plant

132+instance ToJSON Plant

133+instance FromJSON Plant

134+

135+

136+main :: IO ()

137+main = do

138+ putStrLn "Connecting to plant farm"

139+ c <- dbConnection

140+ _ <- createSchema c

141+ putStrLn "Planting some plants"

142+ _ <- insertSampleData c

143+ let port = 8001

144+ putStrLn $ "Started Plant farm at " <> show port

145+ S.scotty port $ do

146+

147+ -- retrieve a plant by name

148+ S.get "/plant/:name" $ do

149+ n <- S.param "name"

150+ e <- liftIO $ getPlant c n

151+ p <- handleWebError e

152+ S.json p

153+

154+

155+ -- save a plant providing it as json data

156+ S.post "/plant" $ do

157+ pl <- S.jsonData :: S.ActionM Plant

158+ e <- liftIO $ savePlant c [pl]

159+ p <- handleWebError e

160+ S.json p

161+

162+ -- updating a plant providing it as json data

163+ S.put "/plant" $ do

164+ pl <- S.jsonData :: S.ActionM Plant

165+ e <- liftIO $ updatePlantFst c pl

166+ p <- handleWebError e

167+ S.json p

168+

169+ -- watering the plant having the provided name.

170+ -- This will water the plant and might let it progress to the next stage. It might also die.

171+ S.post "/plant/water/:name" $ do

172+ n <- S.param "name"

173+ e <- liftIO $ waterPlant c n

174+ p <- handleWebError e

175+ S.json p

176+

177+ -- retriving all the plants as json data

178+ S.get "/plants" $ do

179+ e <- liftIO $ getAllPlants c

180+ ps <- handleWebErrors e

181+ S.json ps

182+

183+ -- saving many plants at the same time

184+ S.post "/plants" $ do

185+ pl <- S.jsonData :: S.ActionM [Plant]

186+ e <- liftIO $ savePlant c pl

187+ p <- handleWebError e

188+ S.json p

189+

190+ -- deleting all plants at a specific stage

191+ S.delete "/plants?stage=:stage" $ do

192+ s <- S.param "stage"

193+ e <- liftIO $ deletePlantsByStage c s

194+ p <- handleWebError e

195+ S.json p

196+

197+ -- deleting all plants at a specific stage

198+ S.delete "/plants" $ do

199+ s <- S.param "name"

200+ e <- liftIO $ deletePlantByName c s

201+ p <- handleWebError e

202+ S.json p

203+

204+ -- deleting all dead plants

205+ S.delete "/plants/clear" $ do

206+ e <- liftIO $ clearDeadPlants c

207+ ps <- handleWebErrors e

208+ S.json ps

209+

210+handleWebError :: Either Err b -> S.ActionM b

211+handleWebError (Left e) = S.raise (TL.pack $ "An error occurred:\n" <> show e)

212+handleWebError (Right v) = pure v

213+

214+handleWebErrors :: [Either Err b] -> S.ActionM [b]

215+handleWebErrors e = do

216+ case lefts e of

217+ [] -> pure (rights e)

218+ l -> S.raise (TL.pack $ "Errors occurred:\n" <> concatMap ((<>"\n") . show) l)

219+

220+

221+-- | watering a plant and thereby possibly updating its stage

222+waterPlant :: DBConnection -> Text -> IO (Either Err Plant)

223+waterPlant db n = do

224+ p <- getPlant db n

225+ case p of

226+ Left e -> pure $ Left e

227+ Right v -> updateStage db $ v { waterings = waterings v + 1 }

228+

229+-- | used by 'waterPlant' updates the stage depending on random numbers

230+updateStage :: DBConnection -> Plant -> IO (Either Err Plant)

231+updateStage db p@(Plant _ _ Dead _ ) = do

232+ tmp <- updatePlantFst db p

233+ case tmp of

234+ Left e -> pure $ Left e

235+ Right _ -> pure $ Right p

236+updateStage db p = do

237+ res <- calculateStage p

238+ tmp <- updatePlantFst db res

239+ case tmp of

240+ Left e -> pure $ Left e

241+ Right _ -> pure $ Right res

242+ where calculateStage p' = do

243+ r1 <- R.randomRIO (1, 10) :: IO Integer

244+ let np = if r1 < waterings p' then p' { stage = next $ stage p', waterings = 0 } else p'

245+ r2 <- R.randomRIO (1, 20)

246+ pure $ if r2 < waterings np then np { stage = Dead, waterings = 0 } else np

247+

248+-- | deletes all plants with Stage = Dead

249+clearDeadPlants :: DBConnection -> IO [Either Err Plant]

250+clearDeadPlants db = do

251+ _ <- deletePlantsByStage db Dead

252+ getAllPlants db

253+

254+

255+-- ****************************

256+-- | *Database functions* :

257+-- ****************************

258+

259+

260+-- | Error type for passing. It is not very specific.

261+-- Just minimal and non optimal for this example.

262+data Err = NotSpecified | NotFound deriving (Show ,Generic)

263+

264+instance ToJSON Err

265+

266+-- | Just for convinience for passing around the SessionId

267+-- and the Connection

268+data DBConnection = DB SessionId Connection

269+

270+

271+-- | Getting plants by their name.\

272+-- Because plant has name as primary key \

273+-- we can assume will get at most one result. \

274+-- Alternatively we could return a list.

275+getPlant :: DBConnection -> Text -> IO (Either Err Plant)

276+getPlant db n = defaultHead (Left NotFound) <$> (

277+ get db

278+ ( Restrict -- Restrict can be thought of as similar to "WITH" in SQL

279+ (AttributeEqualityPredicate "name" (NakedAtomExpr (toAtom n))) -- This is the Predicate we are "restricting" our RelationalExprBase with

280+ (RelationVariable "plants" ())

281+ )

282+ :: IO [Either Err Plant] -- this is needed because our 'get' function is

283+ )

284+

285+defaultHead :: a -> [a] -> a

286+defaultHead d [] = d

287+defaultHead _ (x:_) = x

288+

289+-- | Getting all the plants

290+getAllPlants :: DBConnection -> IO [Either Err Plant]

291+getAllPlants db = get db (RelationVariable "plants" ())

292+

293+-- | Getting all the plants that satisfy the restrictions

294+getAllPlantsWith :: DBConnection -> Base.RestrictionPredicateExpr -> IO [Either Err Plant]

295+getAllPlantsWith db ex = get db (Restrict ex (RelationVariable "plants" ()))

296+

297+

298+-- | Saving a plant

299+savePlant :: (Traversable t) => DBConnection -> t Plant -> IO (Either Err ())

300+savePlant db sps = insert db sps "plants"

301+

302+-- | An alternative to update alone because due to updates

303+-- not being cached yet \

304+-- they have to be calculated every update. \

305+-- This seems like an alternative until caching is implemented.

306+updatePlantFst :: DBConnection -> Plant -> IO (Either Err ())

307+updatePlantFst db pln = do

308+ _ <- delete db pln ["name"] "plants"

309+ savePlant db [pln]

310+

311+-- | Updating a plant. Due to the way project 36 works, \

312+-- updates have to be executed every time.\

313+-- This is slow but won't be an issue soon because they will

314+-- be cached.\

315+-- But because of this project 36 can provide O(1) commits.

316+updatePlant :: DBConnection -> Plant -> IO (Either Err ())

317+updatePlant db sps = update

318+ db -- db connection

319+ sps -- plant value

320+ ["name"] -- the attributes to be updated by (in case of unique key)

321+ "plants" -- the relation we want to update on

322+

323+

324+-- | deleting all plants that have given name.

325+deletePlantByName :: DBConnection -> Text -> IO (Either Err ())

326+deletePlantByName db s = executeWithTransaction db $ Right $ Delete "plants" $ AttributeEqualityPredicate "name" (NakedAtomExpr (toAtom s))

327+

328+-- | deleting all plants that have given stage.

329+deletePlantsByStage :: DBConnection -> Stage -> IO (Either Err ())

330+deletePlantsByStage db s = executeWithTransaction db $ Right $ Delete "plants" $ AttributeEqualityPredicate "stage" (NakedAtomExpr (toAtom s))

331+

332+

333+-- | Inserting the schema into the DB

334+createSchema :: DBConnection -> IO ()

335+createSchema (DB sessionId conn) = do

336+ _ <- handleIOErrorsAndQuit $ mapM (executeDatabaseContextExpr sessionId conn) [

337+ toAddTypeExpr (Proxy :: Proxy Stage) -- Adds the Type Stage as data to the DB

338+ , toDefineExpr (Proxy :: Proxy Plant) "plants" -- Creates the plants relation

339+ , databaseContextExprForUniqueKey "plants" ["name"] -- Makes name of the plants relation a uniqe Key,

340+ -- Foreign Key restrictions are available too

341+ ]

342+ pure ()

343+

344+

345+-- | inserting some sample data

346+insertSampleData :: DBConnection -> IO (Either Err ())

347+insertSampleData (DB sid conn) = do

348+ insert (DB sid conn) [

349+ Plant "angu" "Caladenia angustata" Seed 0

350+ , Plant "thely" "Thelymitra alcockiae" Seed 0

351+ , Plant "monstera" "Araceae" Seed 0

352+ ] "plants"

353+

354+dbConnection :: IO DBConnection

355+dbConnection = do

356+ -- connect to the database

357+ let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []

358+ -- The code below persists the data in a DB with the name "base". \\

359+-- let connInfo = InProcessConnectionInfo (CrashSafePersistence "base") emptyNotificationCallback [] \\

360+ -- In addition minimal persistance is available. \\

361+-- let connInfo = InProcessConnectionInfo (MinimalPersistence "base") emptyNotificationCallback []

362+ conn <- handleIOErrorAndQuit $ connectProjectM36 connInfo

363+ --create a database session at the default branch of the database

364+ sessionId <- handleIOErrorAndQuit $ createSessionAtHead conn defaultHeadName

365+ pure (DB sessionId conn)

366+

367+

368+-- | A polymorphic function to insert data (a traversable of data) into the DB

369+insert :: (Tupleable a, Traversable t) => DBConnection -> t a -> Base.RelVarName -> IO (Either Err ())

370+insert db rlv rlvName = executeWithTransaction db $ toInsertExpr rlv rlvName

371+

372+-- | A polymorphic function to update data in the DB.

373+-- An update in one funtion would take:

374+--

375+-- - SessionId

376+-- - Connection

377+-- - Tuplable a -- the Tuplable you want to update

378+-- - [AttributeName] -- the Attributes of the Tuplable you want to update those are of StringType

379+-- - RelVarName -- the name of the relation

380+--

381+-- With that you can via 'toUpdateExpr' create a 'DatabaseContextExpr' to be executed. \\

382+-- For inserting its very similarly done with 'toInsertExpr'.

383+update :: (Tupleable a) => DBConnection -> a -> [AttributeName]-> Base.RelVarName -> IO (Either Err ())

384+update db rlv attr rlvName = executeWithTransaction db $ toUpdateExpr rlvName attr rlv

385+

386+-- | A polymorphic function to delete data in the DB

387+delete :: (Tupleable a) => DBConnection -> a -> [AttributeName]-> Base.RelVarName -> IO (Either Err ())

388+delete db rlv attr rlvName = executeWithTransaction db $ toDeleteExpr rlvName attr rlv

389+

390+-- | A convenience function to make executing DBContextExpr with commiting simpler. \\

391+-- In particular for expr that just insert, delete and update.

392+-- Therefor ultimately return Either _ ()

393+executeWithTransaction :: DBConnection -> Either RelationalError DatabaseContextExpr -> IO (Either Err ())

394+executeWithTransaction (DB sid conn) expr = do

395+ iEx <- handleError expr

396+ case iEx of

397+ Left e -> pure $ Left e

398+ Right v -> handleIOError $ withTransaction sid conn (executeDatabaseContextExpr sid conn v) (commit sid conn)

399+

400+-- | A polymorphic function to get data (a list of data and possibly errors) from the DB

401+get :: Tupleable b => DBConnection -> Base.RelationalExpr -> IO [Either Err b]

402+get (DB sessionId conn) q = do

403+ eRel <- executeRelationalExpr sessionId conn q

404+ e <- handleError eRel

405+ case e of

406+ Left err -> pure [Left err]

407+ Right pRel -> do

408+ ws <- Relation.toList pRel

409+ mapM (handleError . fromTuple) ws

410+

411+-- | for closing the DB connection.

412+-- Not really needed when using in-memory DB

413+closeConn :: DBConnection -> IO ()

414+closeConn (DB _ conn) = close conn

415+

416+

417+-- | Error handling is heavily inspired by 'blog.hs' the blog example \\

418+-- by (agentm)[https://github.com/agentm] (https://github.com/agentm/project-m36, commit: f8432522adaafeae7c32bc2b8b6cb09c00396fc6). \\

419+-- As stated there, your application should have proper error handling.

420+handleIOErrorAndQuit :: Show e => IO (Either e a) -> IO a

421+handleIOErrorAndQuit m = do

422+ v <- m

423+ handleErrorAndQuit v

424+

425+handleError :: Show e => Either e a -> IO (Either Err a)

426+handleError eErr = case eErr of

427+ Left err -> print err $> Left NotSpecified

428+ Right v -> pure $ Right v

429+

430+handleIOError :: Show e => IO (Either e a) -> IO (Either Err a)

431+handleIOError m = do

432+ v <- m

433+ handleError v

434+

435+handleErrorAndQuit :: Show e => Either e a -> IO a

436+handleErrorAndQuit eErr = case eErr of

437+ Left err -> print err >> error "Quit."

438+ Right v -> pure v

439+

440+handleIOErrorsAndQuit :: Show e => IO [Either e a] -> IO [a]

441+handleIOErrorsAndQuit m = do

442+ eErrs <- m

443+ case lefts eErrs of

444+ [] -> pure (rights eErrs)

445+ err:_ -> handleErrorAndQuit (Left err)

446+

examples/SimpleClient.hs+1−1

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

66main :: IO ()

77main = do

88 -- 1. create a ConnectionInfo

9− let connInfo = RemoteProcessConnectionInfo "mytestdb" (createNodeId "127.0.0.1" defaultServerPort) emptyNotificationCallback

9+ let connInfo = RemoteConnectionInfo "mytestdb" "127.0.0.1" (show defaultServerPort) emptyNotificationCallback

1010 -- 2. conncted to the remote database

1111 eConn <- connectProjectM36 connInfo

1212 case eConn of

examples/blog.hs+5−4

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

11-- a simple example of a blog schema

2−{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings, CPP #-}

2+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings, CPP, DerivingVia #-}

44import ProjectM36.Client

55import ProjectM36.Base

@@ -10,18 +10,18 @@ import ProjectM36.Tuple (atomForAttributeName)

1010

1111import Data.Either

1212import GHC.Generics

13−import Data.Binary

1413import qualified Data.Text as T

1514import qualified Data.Text.Lazy as TL

1615import Data.Time.Clock

1716import Data.Time.Calendar

1817import Control.DeepSeq

1918import Data.Proxy

20−#if __GLASGOW_HASKELL__ <= 802

19+#if __GLASGOW_HASKELL__ < 804

2120import Data.Monoid

2221#endif

2322import Data.List

2423import Control.Monad (when, forM_)

24+import Codec.Winery

2525

2626import Web.Scotty as S

2727import Text.Blaze.Html5 (h1, h2, h3, p, form, input, (!), toHtml, Html, a, toValue, hr, textarea)

@@ -52,7 +52,8 @@ data Comment = Comment {

5252instance Tupleable Comment

5353

5454data Category = Food | Cats | Photos | Other T.Text -- note that this data type could not be represented by an "enumeration" as found in SQL databases

55− deriving (Atomable, Eq, Show, NFData, Binary, Generic) -- derive Atomable so that values of this type can be stored as a database value

55+ deriving (Atomable, Eq, Show, NFData, Generic) -- derive Atomable so that values of this type can be stored as a database value

56+ deriving Serialise via WineryVariant Category -- derive Serialisable to be able to transmit this data remotely

5657

5758-- add some short-hand error handling- your application should have proper handling

5859handleIOError :: Show e => IO (Either e a) -> IO a

examples/hair.hs+9−6

@@ -1,16 +1,17 @@

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

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

22import ProjectM36.Client

33import ProjectM36.Relation.Show.Term

44import GHC.Generics

55import Data.Text

6−import Data.Binary

76import Control.DeepSeq

87import qualified Data.Map as M

98import qualified Data.Text.IO as TIO

109import Data.Proxy

10+import Codec.Winery

1111

1212data Hair = Bald | Brown | Blond | OtherColor Text

13− deriving (Generic, Show, Eq, Binary, NFData, Atomable)

13+ deriving (Generic, Show, Eq, NFData, Atomable)

14+ deriving Serialise via WineryVariant Hair

1415

1516main :: IO ()

1617main = do

@@ -31,11 +32,13 @@ main = do

3132

3233 --create a relation with the new Hair AtomType

3334 let blond = NakedAtomExpr (toAtom Blond)

34− eCheck $ executeDatabaseContextExpr sessionId conn (Assign "people" (MakeRelationFromExprs Nothing [

35− TupleExpr (M.fromList [("hair", blond), ("name", NakedAtomExpr (TextAtom "Colin"))])]))

35+ eCheck $ executeDatabaseContextExpr sessionId conn

36+ (Assign "people"

37+ (MakeRelationFromExprs Nothing $ TupleExprs () [

38+ TupleExpr (M.fromList [("hair", blond), ("name", NakedAtomExpr (TextAtom "Colin"))])]))

3639

3740 let restrictionPredicate = AttributeEqualityPredicate "hair" blond

3841 peopleRel <- eCheck $ executeRelationalExpr sessionId conn (Restrict restrictionPredicate (RelationVariable "people" ()))

3942

4043 TIO.putStrLn (showRelation peopleRel)

41−

44+

examples/out_of_the_tarpit.hs+11−7

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

11-- the Out-of-the-Tarpit example in Haskell and Project:M36

2−{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-}

2+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings, DerivingVia #-}

33import ProjectM36.Client

44import ProjectM36.DataTypes.Primitive

55import ProjectM36.Tupleable

@@ -7,11 +7,11 @@ import ProjectM36.Relation

77import ProjectM36.Error

88import Data.Either

99import GHC.Generics

10−import Data.Binary

1110import Control.DeepSeq

1211import qualified Data.Text as T

1312import Data.Time.Calendar

1413import Data.Proxy

14+import Codec.Winery

1515

1616--create various database value (atom) types

1717type Price = Double

@@ -21,16 +21,20 @@ type Name = T.Text

2121type Address = T.Text

2222

2323data RoomType = Kitchen | Bathroom | LivingRoom

24− deriving (Generic, Atomable, Eq, Show, Binary, NFData)

24+ deriving (Generic, Atomable, Eq, Show, NFData)

25+ deriving Serialise via WineryVariant RoomType

2526

2627data PriceBand = Low | Medium | High | Premium

27− deriving (Generic, Atomable, Eq, Show, Binary, NFData)

28+ deriving (Generic, Atomable, Eq, Show, NFData)

29+ deriving Serialise via WineryVariant PriceBand

2830

2931data AreaCode = City | Suburban | Rural

30− deriving (Generic, Atomable, Eq, Show, Binary, NFData)

32+ deriving (Generic, Atomable, Eq, Show, NFData)

33+ deriving Serialise via WineryVariant AreaCode

3134

3235data SpeedBand = VeryFastBand | FastBand | MediumBand | SlowBand

33− deriving (Generic, Atomable, Eq, Show, Binary, NFData)

36+ deriving (Generic, Atomable, Eq, Show, NFData)

37+ deriving Serialise via WineryVariant SpeedBand

3438

3539main :: IO ()

3640main = do

@@ -257,4 +261,4 @@ handleIOErrors m = do

257261 [] -> pure (rights eErrs)

258262 errs -> handleError (Left (someErrors errs))

259263

260−

264+

examples/out_of_the_tarpit.tutd+4−4

@@ -3,9 +3,9 @@

33data Address = Address Text

44data Agent = Agent Text

55data Name = Name Text

6−data Price = Price Double

6+data Price = Price Integer --dollars

77data RoomType = Kitchen | Bathroom | LivingRoom

8−data PriceBand = Low | Medium | High | Premium

8+data PriceBand = Low | Med | High | Premium

99data AreaCode = City | Suburban | Rural

1010data SpeedBand = VeryFast | Fast | Medium | Slow

1111

@@ -57,9 +57,9 @@ constraint noOffersAfterSale (offer join decision where ^dayEarlierThan(@offerDa

5757--1. identify offerPrices > 2000 (arbitrarily-chosen high price band which is not specified in the paper)

5858--2. remove the properties which have been sold

5959--3. group and count sub-relation and restrict by greater than 50

60−constraint noMoreThan50PremiumProperties ((((property where ^gt(offerPrice,2000.0)) minus ((property join decision){address,agent,dateRegistered,photo,price})) group ({} as x) : {z:=gt(count(@x),50)}) {z}){} equals false

60+constraint noMoreThan50PremiumProperties ((((property where ^gt(@price,Price 2000)) minus ((property join decision){address,agent,dateRegistered,photo,price})) group ({} as x) : {z:=gt(count(@x),50)}) {z}){} equals false

6161

62−constraint noBidderCanMakeMoreThan10BidsOnAProperty (((offer group ({all but bidderAddress} as bidder)) : {bidCount:=gt(count(@bidder),10)}) where ^gt(bidCount,10)) {} equals false

62+constraint noBidderCanMakeMoreThan10BidsOnAProperty (((offer group ({all but bidderAddress} as bidder)) : {bidCount:=gt(count(@bidder),10)}) where ^gt(@bidCount,10)) {} equals false

6363

6464-- sample data

6565

jupyter/TutorialD Notebook Walkthrough.ipynb+1−1

@@ -38,7 +38,7 @@

3838 }

3939 ],

4040 "source": [

41− ":importexample date"

41+ ":importexample cjdate"

4242 ]

4343 },

4444 {

nix/sources.jsonnew file+50

@@ -0,0 +1,50 @@

1+{

2+ "curryer": {

3+ "branch": "master",

4+ "description": "Fast Haskell RPC",

5+ "homepage": null,

6+ "owner": "agentm",

7+ "repo": "curryer",

8+ "rev": "74ecaac619ad1165a4517d5c0f4e530493bda130",

9+ "sha256": "1izdvzj00k0y76ixm7dfgvq2fzphb8h4nzqgwkl3p0bg0806rsn1",

10+ "type": "tarball",

11+ "url": "https://github.com/agentm/curryer/archive/74ecaac619ad1165a4517d5c0f4e530493bda130.tar.gz",

12+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

13+ },

14+ "niv": {

15+ "branch": "master",

16+ "description": "Easy dependency management for Nix projects",

17+ "homepage": "https://github.com/nmattia/niv",

18+ "owner": "nmattia",

19+ "repo": "niv",

20+ "rev": "1819632b5823e0527da28ad82fecd6be5136c1e9",

21+ "sha256": "08jz17756qchq0zrqmapcm33nr4ms9f630mycc06i6zkfwl5yh5i",

22+ "type": "tarball",

23+ "url": "https://github.com/nmattia/niv/archive/1819632b5823e0527da28ad82fecd6be5136c1e9.tar.gz",

24+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

25+ },

26+ "nixpkgs": {

27+ "branch": "master",

28+ "description": "Nix Packages collection",

29+ "homepage": "",

30+ "owner": "NixOS",

31+ "repo": "nixpkgs",

32+ "rev": "429c23aad0fce9ef38b0e60d55d7459c19d53ddc",

33+ "sha256": "1nj8sh1fnxp07jdlvjkijwfd1pnsi2zj0ivy7a0dhx02g63byhg3",

34+ "type": "tarball",

35+ "url": "https://github.com/NixOS/nixpkgs/archive/429c23aad0fce9ef38b0e60d55d7459c19d53ddc.tar.gz",

36+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

37+ },

38+ "streamly": {

39+ "branch": "ac3af8749194f1788704dda8667d0b3807075cc2",

40+ "description": "Beautiful Streaming, Concurrent and Reactive Composition (Haskell)",

41+ "homepage": "https://hackage.haskell.org/package/streamly",

42+ "owner": "composewell",

43+ "repo": "streamly",

44+ "rev": "ac3af8749194f1788704dda8667d0b3807075cc2",

45+ "sha256": "04d8fk654vawdfs0dfidmq2awwgwi8x44iv8r7vqz70zkcsd5fij",

46+ "type": "tarball",

47+ "url": "https://github.com/composewell/streamly/archive/ac3af8749194f1788704dda8667d0b3807075cc2.tar.gz",

48+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

49+ }

50+}

nix/sources.nixnew file+171

@@ -0,0 +1,171 @@

1+# This file has been generated by Niv.

3+let

5+ #

6+ # The fetchers. fetch_<type> fetches specs of type <type>.

7+ #

9+ fetch_file = pkgs: name: spec:

10+ let

11+ name' = sanitizeName name + "-src";

12+ in

13+ if spec.builtin or true then

14+ builtins_fetchurl { inherit (spec) url sha256; name = name'; }

15+ else

16+ pkgs.fetchurl { inherit (spec) url sha256; name = name'; };

17+

18+ fetch_tarball = pkgs: name: spec:

19+ let

20+ name' = sanitizeName name + "-src";

21+ in

22+ if spec.builtin or true then

23+ builtins_fetchTarball { name = name'; inherit (spec) url sha256; }

24+ else

25+ pkgs.fetchzip { name = name'; inherit (spec) url sha256; };

26+

27+ fetch_git = name: spec:

28+ let

29+ ref =

30+ if spec ? ref then spec.ref else

31+ if spec ? branch then "refs/heads/${spec.branch}" else

32+ if spec ? tag then "refs/tags/${spec.tag}" else

33+ abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!";

34+ in

35+ builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; };

36+

37+ fetch_local = spec: spec.path;

38+

39+ fetch_builtin-tarball = name: throw

40+ ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`.

41+ $ niv modify ${name} -a type=tarball -a builtin=true'';

42+

43+ fetch_builtin-url = name: throw

44+ ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`.

45+ $ niv modify ${name} -a type=file -a builtin=true'';

46+

47+ #

48+ # Various helpers

49+ #

50+

51+ # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695

52+ sanitizeName = name:

53+ (

54+ concatMapStrings (s: if builtins.isList s then "-" else s)

55+ (

56+ builtins.split "[^[:alnum:]+._?=-]+"

57+ ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name)

58+ )

59+ );

60+

61+ # The set of packages used when specs are fetched using non-builtins.

62+ mkPkgs = sources: system:

63+ let

64+ sourcesNixpkgs =

65+ import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; };

66+ hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;

67+ hasThisAsNixpkgsPath = <nixpkgs> == ./.;

68+ in

69+ if builtins.hasAttr "nixpkgs" sources

70+ then sourcesNixpkgs

71+ else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then

72+ import <nixpkgs> {}

73+ else

74+ abort

75+ ''

76+ Please specify either <nixpkgs> (through -I or NIX_PATH=nixpkgs=...) or

77+ add a package called "nixpkgs" to your sources.json.

78+ '';

79+

80+ # The actual fetching function.

81+ fetch = pkgs: name: spec:

82+

83+ if ! builtins.hasAttr "type" spec then

84+ abort "ERROR: niv spec ${name} does not have a 'type' attribute"

85+ else if spec.type == "file" then fetch_file pkgs name spec

86+ else if spec.type == "tarball" then fetch_tarball pkgs name spec

87+ else if spec.type == "git" then fetch_git name spec

88+ else if spec.type == "local" then fetch_local spec

89+ else if spec.type == "builtin-tarball" then fetch_builtin-tarball name

90+ else if spec.type == "builtin-url" then fetch_builtin-url name

91+ else

92+ abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}";

93+

94+ # If the environment variable NIV_OVERRIDE_${name} is set, then use

95+ # the path directly as opposed to the fetched source.

96+ replace = name: drv:

97+ let

98+ saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;

99+ ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";

100+ in

101+ if ersatz == "" then drv else ersatz;

102+

103+ # Ports of functions for older nix versions

104+

105+ # a Nix version of mapAttrs if the built-in doesn't exist

106+ mapAttrs = builtins.mapAttrs or (

107+ f: set: with builtins;

108+ listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set))

109+ );

110+

111+ # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295

112+ range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1);

113+

114+ # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257

115+ stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1));

116+

117+ # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269

118+ stringAsChars = f: s: concatStrings (map f (stringToCharacters s));

119+ concatMapStrings = f: list: concatStrings (map f list);

120+ concatStrings = builtins.concatStringsSep "";

121+

122+ # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331

123+ optionalAttrs = cond: as: if cond then as else {};

124+

125+ # fetchTarball version that is compatible between all the versions of Nix

126+ builtins_fetchTarball = { url, name ? null, sha256 }@attrs:

127+ let

128+ inherit (builtins) lessThan nixVersion fetchTarball;

129+ in

130+ if lessThan nixVersion "1.12" then

131+ fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))

132+ else

133+ fetchTarball attrs;

134+

135+ # fetchurl version that is compatible between all the versions of Nix

136+ builtins_fetchurl = { url, name ? null, sha256 }@attrs:

137+ let

138+ inherit (builtins) lessThan nixVersion fetchurl;

139+ in

140+ if lessThan nixVersion "1.12" then

141+ fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))

142+ else

143+ fetchurl attrs;

144+

145+ # Create the final "sources" from the config

146+ mkSources = config:

147+ mapAttrs (

148+ name: spec:

149+ if builtins.hasAttr "outPath" spec

150+ then abort

151+ "The values in sources.json should not have an 'outPath' attribute"

152+ else

153+ spec // { outPath = replace name (fetch config.pkgs name spec); }

154+ ) config.sources;

155+

156+ # The "config" used by the fetchers

157+ mkConfig =

158+ { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null

159+ , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)

160+ , system ? builtins.currentSystem

161+ , pkgs ? mkPkgs sources system

162+ }: rec {

163+ # The sources, i.e. the attribute set of spec name to spec

164+ inherit sources;

165+

166+ # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers

167+ inherit pkgs;

168+ };

169+

170+in

171+mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); }

project-m36.cabal+168−160

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

1+Cabal-Version: 2.2

12Name: project-m36

2−Version: 0.6

3−License: PublicDomain

3+Version: 0.9.3

4+License: MIT

5+--note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain

46Build-Type: Simple

57Homepage: https://github.com/agentm/project-m36

68Bug-Reports: https://github.com/agentm/project-m36/issues

@@ -8,7 +10,6 @@ Author: AgentM

810Stability: experimental

911Category: Relational Algebra

1012Maintainer: agentm@themactionfaction.com

11−Cabal-Version: >= 1.10

1213Synopsis: Relational Algebra Engine

1314Description: A relational algebra engine which can be used to persist and query Haskell data types.

1415Extra-Source-Files: Changelog.markdown README.markdown

@@ -28,8 +29,21 @@ Flag stack

2829 Manual: True

2930 Default: False

3031

32+Flag haskell-scripting

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

34+ Manual: True

35+ Default: True

36+

3137Library

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

38+ Build-Depends: base>=4.8 && < 4.15, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery, curryer-rpc, network, async, vector-instances, recursion-schemes, streamly >= 0.7.2, convertible

39+ if flag(haskell-scripting)

40+ Build-Depends: ghc >= 8.2 && < 8.11

41+ CPP-Options: -DPM36_HASKELL_SCRIPTING

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

43+ build-depends:

44+ ghc-boot, ghci

45+ if impl(ghc>= 8.6)

46+ Build-Depends: deferred-folds

3347 Exposed-Modules: ProjectM36.Error,

3448 ProjectM36.Transaction,

3549 ProjectM36.TransactionGraph,

@@ -38,6 +52,8 @@ Library

3852 ProjectM36.TransactionGraph.Merge,

3953 ProjectM36.TransGraphRelationalExpression,

4054 ProjectM36.Base,

55+ ProjectM36.Serialise.Base,

56+ ProjectM36.Serialise.Error,

4157 ProjectM36.DataFrame,

4258 ProjectM36.Attribute,

4359 ProjectM36.AttributeNames,

@@ -47,6 +63,7 @@ Library

4763 ProjectM36.AtomFunction,

4864 ProjectM36.AtomFunctionError,

4965 ProjectM36.ScriptSession,

66+ ProjectM36.Shortcuts,

5067 ProjectM36.DatabaseContextFunction,

5168 ProjectM36.DatabaseContextFunctionError,

5269 ProjectM36.DatabaseContextFunctionUtils,

@@ -66,6 +83,7 @@ Library

6683 ProjectM36.Relation.Parse.CSV,

6784 ProjectM36.IsomorphicSchema,

6885 ProjectM36.InclusionDependency,

86+ ProjectM36.MerkleHash,

6987 ProjectM36.Client,

7088 ProjectM36.Client.Simple,

7189 ProjectM36.Persist,

@@ -75,6 +93,7 @@ Library

7593 ProjectM36.AtomFunctions.Primitive,

7694 ProjectM36.Atomable,

7795 ProjectM36.Tupleable,

96+ ProjectM36.Tupleable.Deriving,

7897 ProjectM36.DataConstructorDef,

7998 ProjectM36.DataTypes.Basic,

8099 ProjectM36.DataTypes.Sorting,

@@ -95,6 +114,10 @@ Library

95114 ProjectM36.Server.EntryPoints,

96115 ProjectM36.Server.ParseArgs,

97116 ProjectM36.Server.RemoteCallTypes,

117+ ProjectM36.Serialise.AtomFunctionError,

118+ ProjectM36.Serialise.DataFrame,

119+ ProjectM36.Serialise.DatabaseContextFunctionError,

120+ ProjectM36.Serialise.IsomorphicSchema,

98121 ProjectM36.Session,

99122 ProjectM36.Sessions,

100123 ProjectM36.Transaction.Persist,

@@ -113,22 +136,20 @@ Library

113136 Other-Modules: ProjectM36.Win32Handle

114137 else

115138 --219- too many exported symbols under Windows and GHC 8.4

116− GHC-Options: -rdynamic

139+ GHC-Options: -rdynamic -fexternal-interpreter

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

118141 Build-Depends: unix

119− CC-Options: -fPIC

142+ CC-Options: -fPIC

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

121144 Default-Language: Haskell2010

122145 Default-Extensions: OverloadedStrings, CPP

123− if impl(ghc>= 8)

124− build-depends:

125− ghc-boot, ghci

126− if !flag(stack)

146+ if !flag(stack)

127147 Build-Depends: deferred-folds

128148

129149Executable tutd

150+ if flag(haskell-scripting)

151+ Build-Depends: ghc >= 8.2 && < 8.11

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

131− ghc >= 7.8 && < 8.5,

132153 ghc-paths,

133154 project-m36,

134155 containers,

@@ -142,13 +163,11 @@ Executable tutd

142163 MonadRandom, MonadRandom,

143164 vector,

144165 text,

145− vector-binary-instances,

146166 time,

147167 hashable-time,

148168 bytestring,

149169 stm,

150170 deepseq,

151− binary,

152171 data-interval,

153172 parallel,

154173 cassava,

@@ -156,14 +175,23 @@ Executable tutd

156175 directory,

157176 filepath,

158177 temporary,

159− megaparsec >= 5.2.0 && < 7,

178+ megaparsec >= 5.2.0 && < 10,

160179 haskeline,

161180 random, MonadRandom,

162181 base64-bytestring,

163182 optparse-applicative,

164183 attoparsec,

165184 stm-containers >= 1.0.0,

166− list-t

185+ list-t,

186+ parser-combinators,

187+ curryer-rpc,

188+ prettyprinter,

189+ cryptohash-sha256,

190+ --due to decode signature change

191+ base16-bytestring >= 1.0.0.0,

192+ http-conduit,

193+ modern-uri,

194+ http-types

167195 Other-Modules: TutorialD.Interpreter,

168196 TutorialD.Interpreter.Base,

169197 TutorialD.Interpreter.DatabaseContextExpr,

@@ -182,6 +210,7 @@ Executable tutd

182210 TutorialD.Interpreter.SchemaOperator,

183211 TutorialD.Interpreter.TransGraphRelationalOperator,

184212 TutorialD.Interpreter.SchemaOperator

213+ TutorialD.Printer

185214 main-is: TutorialD/tutd.hs

186215 CC-Options: -fPIC

187216 GHC-Options: -Wall -threaded

@@ -190,12 +219,12 @@ Executable tutd

190219 Default-Extensions: OverloadedStrings

191220

192221Executable project-m36-server

222+ if flag(haskell-scripting)

223+ Build-Depends: ghc >= 8.2 && < 8.11

193224 Build-Depends: base,

194− ghc >= 7.8 && < 8.5,

195225 ghc-paths,

196− project-m36,

197− binary,

198226 transformers,

227+ project-m36,

199228 temporary,

200229 data-interval,

201230 deepseq,

@@ -208,7 +237,6 @@ Executable project-m36-server

208237 optparse-applicative,

209238 hashable-time,

210239 time,

211− vector-binary-instances,

212240 text,

213241 deepseq-generics,

214242 mtl,

@@ -221,11 +249,32 @@ Executable project-m36-server

221249 list-t,

222250 base64-bytestring

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

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

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

253+ if flag(profiler)

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

255+ Default-Language: Haskell2010

256+ Default-Extensions: OverloadedStrings

257+

258+Executable bigrel

259+ Default-Language: Haskell2010

260+ Default-Extensions: OverloadedStrings

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

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

263+ TutorialD.Interpreter.DatabaseContextExpr,

264+ TutorialD.Interpreter.RelationalExpr,

265+ TutorialD.Interpreter.Types

266+ main-is: benchmark/bigrel.hs

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

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

225269 if flag(profiler)

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

271+

272+Common commontest

227273 Default-Language: Haskell2010

274+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups, parser-combinators, winery, curryer-rpc, prettyprinter, base64-bytestring, modern-uri, http-types, http-conduit, base16-bytestring,cryptohash-sha256

228275 Default-Extensions: OverloadedStrings

276+ GHC-Options: -Wall -threaded

277+ Hs-Source-Dirs: test, src/bin

229278

230279Benchmark basic-benchmark

231280 Default-Language: Haskell2010

@@ -238,240 +287,202 @@ Benchmark basic-benchmark

238287 if flag(profiler)

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

240289

290+--benchmark inserts, updates, deletes for a basic use-case to shake out any space leaks

291+Benchmark update-exprs

292+ Default-Language: Haskell2010

293+ Default-Extensions: OverloadedStrings

294+ Build-Depends: base, criterion, project-m36, text, winery

295+ Main-Is: benchmark/Server.hs

296+ Type: exitcode-stdio-1.0

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

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

299+ if flag(profiler)

300+ GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall -fexternal-interpreter

301+

241302Test-Suite test-tutoriald

242− Default-Language: Haskell2010

243− Default-Extensions: OverloadedStrings

303+ import: commontest

244304 type: exitcode-stdio-1.0

245− main-is: test/TutorialD/Interpreter.hs

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

247− Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator

248− GHC-Options: -Wall -threaded

249− Hs-Source-Dirs: ./src/bin, ., test

305+ main-is: TutorialD/InterpreterTest.hs

306+ Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer

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

250308

251309Test-Suite test-tutoriald-atomfunctionscript

252− Default-Language: Haskell2010

253− Default-Extensions: OverloadedStrings

310+ import: commontest

254311 type: exitcode-stdio-1.0

255− Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator

256− main-is: test/TutorialD/Interpreter/AtomFunctionScript.hs

257− Build-Depends: base, HUnit, project-m36, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups, time

258− GHC-Options: -Wall -threaded

259− Hs-Source-Dirs: ./src/bin, ./test, .

312+ Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer

313+ main-is: TutorialD/Interpreter/AtomFunctionScript.hs

260314

261315Test-Suite test-tutoriald-databasecontextfunctionscript

262− Default-Language: Haskell2010

263− Default-Extensions: OverloadedStrings

316+ import: commontest

264317 type: exitcode-stdio-1.0

265− Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator

266− main-is: test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs

267− Build-Depends: base, HUnit, project-m36, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups, time

268− GHC-Options: -Wall -threaded

269− Hs-Source-Dirs: ./src/bin, ./test, .

318+ Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer

319+ main-is: TutorialD/Interpreter/DatabaseContextFunctionScript.hs

270320

271321Test-Suite test-relation

272− Default-Language: Haskell2010

273− Default-Extensions: OverloadedStrings

322+ import: commontest

274323 type: exitcode-stdio-1.0

275− main-is: test/Relation/Basic.hs

276− 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, stm-containers, project-m36, transformers

277− GHC-Options: -Wall -threaded

324+ main-is: Relation/Basic.hs

278325

279326Test-Suite test-static-optimizer

280− Default-Language: Haskell2010

281− Default-Extensions: OverloadedStrings

327+ import: commontest

282328 type: exitcode-stdio-1.0

283− main-is: test/Relation/StaticOptimizer.hs

284− 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, stm-containers, project-m36, transformers

285− GHC-Options: -Wall -threaded

329+ main-is: Relation/StaticOptimizer.hs

286330

287331Test-Suite test-transactiongraph-persist

288− Default-Language: Haskell2010

289− Default-Extensions: OverloadedStrings

332+ import: commontest

290333 type: exitcode-stdio-1.0

291− main-is: test/TransactionGraph/Persist.hs

292− 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, stm-containers, project-m36, random, MonadRandom, semigroups

293− Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples

294− Hs-Source-Dirs: ., ./src/bin

295− GHC-Options: -Wall -threaded

334+ main-is: TransactionGraph/Persist.hs

335+ Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer

296336

297337Test-Suite test-relation-import-csv

298− Default-Language: Haskell2010

299− Default-Extensions: OverloadedStrings

338+ import: commontest

300339 type: exitcode-stdio-1.0

301− main-is: test/Relation/Import/CSV.hs

302− 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, stm-containers, project-m36

303− GHC-Options: -Wall -threaded

340+ main-is: Relation/Import/CSV.hs

304341

305342Test-Suite test-tutoriald-import-tutoriald

306− Default-Language: Haskell2010

307− Default-Extensions: OverloadedStrings

343+ import: commontest

308344 type: exitcode-stdio-1.0

309− main-is: test/TutorialD/Interpreter/Import/TutorialD.hs

310− 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, stm-containers, project-m36, random, MonadRandom, semigroups

311− Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples

312− GHC-Options: -Wall -threaded

313− Hs-Source-Dirs: ., ./src/bin

345+ main-is: TutorialD/Interpreter/Import/ImportTest.hs

346+ Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer

314347

315348Test-Suite test-relation-export-csv

316− Default-Language: Haskell2010

317− Default-Extensions: OverloadedStrings

349+ import: commontest

318350 type: exitcode-stdio-1.0

319− main-is: test/Relation/Export/CSV.hs

320− 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, stm-containers, project-m36

321− GHC-Options: -Wall -threaded

351+ main-is: Relation/Export/CSV.hs

322352

323353Test-Suite test-transactiongraph-merge

324− Default-Language: Haskell2010

325− Default-Extensions: OverloadedStrings

354+ import: commontest

326355 type: exitcode-stdio-1.0

327− main-is: test/TransactionGraph/Merge.hs

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

329− GHC-Options: -Wall -threaded

356+ main-is: TransactionGraph/Merge.hs

357+

358+

359+Test-Suite test-prettyprinter

360+ import: commontest

361+ type: exitcode-stdio-1.0

362+ main-is: TutorialD/PrinterTest.hs

363+ Other-Modules: TutorialD.Printer, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types

330364

331365benchmark bench

332− Default-Language: Haskell2010

333− Default-Extensions: OverloadedStrings

366+ import: commontest

334367 type: exitcode-stdio-1.0

335368 main-is: benchmark/Relation.hs

336− 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, criterion, stm-containers, project-m36

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

338− Hs-Source-Dirs: ./src/bin

339369

340370Test-Suite test-server

341− Default-Language: Haskell2010

342− Default-Extensions: OverloadedStrings

371+ import: commontest

343372 type: exitcode-stdio-1.0

344− main-is: test/Server/Main.hs

345− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, 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, project-m36, network-transport, semigroups

346− HS-Source-Dirs: ., ./src/bin

347− GHC-Options: -Wall -threaded

373+ main-is: Server/Main.hs

374+

348375

349376Executable Example-SimpleClient

350377 Default-Language: Haskell2010

351378 Default-Extensions: OverloadedStrings

352− 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, ghc, ghc-paths, project-m36, random, MonadRandom

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

353380 Main-Is: examples/SimpleClient.hs

354381 GHC-Options: -Wall -threaded

355382

356383Executable Example-OutOfTheTarpit

357384 Default-Language: Haskell2010

358385 Default-Extensions: OverloadedStrings

359− 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

386+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,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, winery

360387 Main-Is: examples/out_of_the_tarpit.hs

361388 GHC-Options: -Wall -threaded

362389

363390Executable Example-Blog

364391 Default-Language: Haskell2010

365392 Default-Extensions: OverloadedStrings

366− 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, scotty, blaze-html, http-types

393+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,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, scotty, blaze-html, http-types, winery

367394 Main-Is: examples/blog.hs

368395 GHC-Options: -Wall -threaded

369396

370−

371397Executable Example-Hair

372398 Default-Language: Haskell2010

373399 Default-Extensions: OverloadedStrings

374− 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

400+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,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, winery

375401 Main-Is: examples/hair.hs

376402 GHC-Options: -Wall -threaded

377403

404+Executable Example-Plantfarm

405+ Default-Language: Haskell2010

406+ Default-Extensions: OverloadedStrings

407+ Build-Depends: aeson, barbies, base, binary, containers, deepseq, hashable, project-m36, random, scotty, text, winery

408+ Main-Is: examples/Plantfarm.hs

409+ GHC-Options: -Wall -threaded

410+

378411Executable Example-CustomTupleable

379412 Default-Language: Haskell2010

380413 Default-Extensions: OverloadedStrings

381− 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

414+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,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, winery

382415 Main-Is: examples/CustomTupleable.hs

383416 GHC-Options: -Wall -threaded

384417

385−Test-Suite test-scripts

418+Executable Example-DerivingCustomTupleable

419+ if impl(ghc>=8.6)

420+ Buildable: True

421+ else

422+ Buildable: False

386423 Default-Language: Haskell2010

387− Default-Extensions: OverloadedStrings

388− type: exitcode-stdio-1.0

389− main-is: test/scripts.hs

390− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, 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, project-m36, random, MonadRandom, semigroups

391− Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.Import.BasicExamples

424+ Build-Depends: base, text, deepseq, project-m36, winery

425+ Main-Is: examples/DerivingCustomTupleable.hs

392426 GHC-Options: -Wall -threaded

393− Hs-Source-Dirs: ., ./src/bin

427+

428+Test-Suite test-scripts

429+ import: commontest

430+ type: exitcode-stdio-1.0

431+ main-is: scripts.hs

432+ Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer

394433

395434Executable project-m36-websocket-server

396435 Default-Language: Haskell2010

397− Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, network-transport-tcp, semigroups, attoparsec

436+ Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, semigroups, attoparsec, parser-combinators, prettyprinter, network, modern-uri, http-conduit, base16-bytestring, http-types, cryptohash-sha256, wai, wai-websockets, warp, warp-tls

398437 Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs

399− Other-Modules: ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator

438+ Other-Modules: ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer

400439 GHC-Options: -Wall -threaded

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

402441 Default-Extensions: OverloadedStrings

403442

404443Test-Suite test-websocket-server

405− Default-Language: Haskell2010

444+ import: commontest

406445 type: exitcode-stdio-1.0

407− main-is: test/Server/WebSocket.hs

408− 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, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, network-transport-tcp, semigroups

409− Other-Modules: TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator

410− Default-Extensions: OverloadedStrings

411− GHC-Options: -Wall -threaded

412− Hs-Source-Dirs: ./src/bin, .

446+ main-is: Server/WebSocket.hs

447+ Other-Modules: TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer

413448

414449Test-Suite test-isomorphic-schemas

415− Default-Language: Haskell2010

450+ import: commontest

416451 type: exitcode-stdio-1.0

417− main-is: test/IsomorphicSchema.hs

418− 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, websockets, optparse-applicative, network, aeson, project-m36

419− Default-Extensions: OverloadedStrings

420− GHC-Options: -Wall -threaded

421− Hs-Source-Dirs: ./src/bin, .

452+ main-is: IsomorphicSchema.hs

422453

423454Test-Suite test-atomable

424− Default-Language: Haskell2010

455+ import: commontest

425456 type: exitcode-stdio-1.0

426− main-is: test/Relation/Atomable.hs

427− 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, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups

428− Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types

429− Default-Extensions: OverloadedStrings

430− GHC-Options: -Wall -threaded

431− Hs-Source-Dirs: ./src/bin, ., test/

457+ main-is: Relation/Atomable.hs

458+ Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer

432459

433460Test-Suite test-multiprocess-access

434− Default-Language: Haskell2010

461+ import: commontest

435462 type: exitcode-stdio-1.0

436− main-is: test/MultiProcessDatabaseAccess.hs

437− 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, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom

438− Default-Extensions: OverloadedStrings

439− GHC-Options: -Wall -threaded

440− Hs-Source-Dirs: ./src/bin, ., test/

463+ main-is: MultiProcessDatabaseAccess.hs

441464

442465Test-Suite test-transactiongraph-automerge

443− Default-Language: Haskell2010

466+ import: commontest

444467 type: exitcode-stdio-1.0

445− main-is: test/TransactionGraph/Automerge.hs

446− 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, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups

447− Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types

448− Default-Extensions: OverloadedStrings

449− GHC-Options: -Wall -threaded

450− Hs-Source-Dirs: ./src/bin, ., test/

468+ main-is: TransactionGraph/Automerge.hs

469+ Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer

451470

452471Test-Suite test-tupleable

453− Default-Language: Haskell2010

472+ import: commontest

454473 type: exitcode-stdio-1.0

455− main-is: test/Relation/Tupleable.hs

456− 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, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups

457− Default-Extensions: OverloadedStrings

458− GHC-Options: -Wall -threaded

459− Hs-Source-Dirs: ./src/bin, ., test/

474+ main-is: Relation/Tupleable.hs

460475

461476Test-Suite test-client-simple

462− Default-Language: Haskell2010

463− Main-Is: test/Client/Simple.hs

477+ import: commontest

478+ Main-Is: Client/Simple.hs

464479 type: exitcode-stdio-1.0

465− 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, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups

466− Default-Extensions: OverloadedStrings

467− GHC-Options: -Wall -threaded

468− Hs-Source-Dirs: ./src/bin, ., test/

469480

470481-- test for file handle leaks

471482Executable handles

472483 Default-Language: Haskell2010

473484 Default-Extensions: OverloadedStrings

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

485+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, modern-uri, http-types, http-conduit, base16-bytestring, cryptohash-sha256

475486 main-is: benchmark/Handles.hs

476487 Other-Modules: TutorialD.Interpreter,

477488 TutorialD.Interpreter.Base,

@@ -490,17 +501,14 @@ Executable handles

490501 TutorialD.Interpreter.TransGraphRelationalOperator,

491502 TutorialD.Interpreter.TransactionGraphOperator,

492503 TutorialD.Interpreter.Types

504+ TutorialD.Printer

493505 GHC-Options: -Wall -threaded -rtsopts

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

495507 if flag(profiler)

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

497−

509+

498510Test-Suite test-dataframe

499− Default-Language: Haskell2010

500− Main-Is: test/DataFrame.hs

511+ import: commontest

501512 type: exitcode-stdio-1.0

502− Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types

503− 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, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups

504− Default-Extensions: OverloadedStrings

505− GHC-Options: -Wall -threaded

506− Hs-Source-Dirs: ./src/bin, ., test/

513+ Main-Is: DataFrame.hs

514+ Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer

release.nixnew file+36

@@ -0,0 +1,36 @@

1+{ compiler ? "ghc8104"

2+, sources ? import ./nix/sources.nix

3+, pkgs ? import sources.nixpkgs { }

4+}:

5+let

6+ doJailbreak = pkgs.haskell.lib.doJailbreak;

7+ needsCocoa = drv:

8+ if pkgs.stdenv.isDarwin

9+ then drv.overrideDerivation (old:

10+ { buildInputs = [ pkgs.darwin.apple_sdk.frameworks.Cocoa ] ++ old.buildInputs; }

11+ )

12+ else drv;

13+

14+ haskellPackages = pkgs.haskell.packages.${compiler}.override {

15+ overrides = self: super: {

16+ curryer-rpc = self.callCabal2nix "curryer-rpc" sources.curryer { };

17+ streamly = doJailbreak (needsCocoa (self.callCabal2nix "streamly" sources.streamly { }));

18+ project-m36 = ((self.callCabal2nixWithOptions "project-m36" ./. "-f-haskell-scripting" { }));

19+ };

20+ };

21+in

22+{

23+ project = haskellPackages.project-m36;

24+

25+ shell = haskellPackages.shellFor {

26+ packages = p: [

27+ p.project-m36

28+ ];

29+ buildInputs = [

30+ haskellPackages.ghcid

31+ haskellPackages.hlint

32+ pkgs.docker

33+ ];

34+ withHoogle = true;

35+ };

36+}

scripts/DateExamples.tutd+2−2

@@ -20,7 +20,7 @@ sp := relation{tuple{s# "S1",p# "P1",qty 300},

2020 tuple{s# "S3",p# "P2",qty 200},

2121 tuple{s# "S4",p# "P4",qty 300},

2222 tuple{s# "S4",p# "P5",qty 400}};

23−key s_pkey {s#} s

24−key p_key {p#} p

23+key s_pkey {s#} s;

24+key p_key {p#} p;

2525foreign key s_sp_fk sp{s#} in s{s#};

2626foreign key p_sp_fk sp{p#} in p{p#};

scripts/multiline.tutdnew file+2

@@ -0,0 +1,2 @@

1+x:=relation{

2+tuple{ x 2}} -- nice

shell.nixnew file+1

@@ -0,0 +1 @@

1+(import ./release.nix { }).shell

src/bin/ProjectM36/Client/Json.hs+4−1

@@ -3,6 +3,7 @@ module ProjectM36.Client.Json where

33import Data.Aeson

44import ProjectM36.Server.RemoteCallTypes.Json ()

55import ProjectM36.Client

6+import ProjectM36.TransactionGraph

67import Control.Exception (IOException)

89instance ToJSON EvaluatedNotification

@@ -11,4 +12,6 @@ instance FromJSON EvaluatedNotification

1112instance ToJSON ConnectionError

1213

1314instance ToJSON IOException where

14− toJSON err = object ["IOException" .= show err]

15+ toJSON err = object ["IOException" .= show err]

16+

17+instance ToJSON MerkleValidationError

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs+33−2

@@ -10,6 +10,8 @@ import ProjectM36.DataTypes.Primitive

1010import ProjectM36.Error

1111import ProjectM36.IsomorphicSchema

1212import ProjectM36.Server.RemoteCallTypes

13+import ProjectM36.MerkleHash

14+import ProjectM36.Attribute as A

1315

1416import Data.Aeson

1517import Data.ByteString.Base64 as B64

@@ -22,6 +24,9 @@ instance FromJSON RelationalExpr

2224instance ToJSON TupleExpr

2325instance FromJSON TupleExpr

2426

27+instance ToJSON TupleExprs

28+instance FromJSON TupleExprs

29+

2530instance ToJSON RestrictionPredicateExpr

2631instance FromJSON RestrictionPredicateExpr

2732

@@ -40,8 +45,11 @@ instance FromJSON ExecuteRelationalExpr

4045instance ToJSON Relation

4146instance FromJSON Relation

4247

43−instance ToJSON Attribute

44−instance FromJSON Attribute

48+instance ToJSON Attribute where

49+ toJSON (Attribute attrName aType) = object [ "name" .= attrName

50+ , "type" .= toJSON aType ]

51+instance FromJSON Attribute where

52+ parseJSON = withObject "Attribute" $ \v -> Attribute <$> v .: "name" <*> v .: "type"

4553

4654instance ToJSON ExtendTupleExpr

4755instance FromJSON ExtendTupleExpr

@@ -95,6 +103,8 @@ instance ToJSON Atom where

95103 "val" .= i ]

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

97105 "val" .= i ]

106+ toJSON atom@(RelationalExprAtom i) = object [ "type" .= atomTypeForAtom atom,

107+ "val" .= i ]

98108 toJSON (ConstructedAtom dConsName atomtype atomlist) = object [

99109 "dataconstructorname" .= dConsName,

100110 "type" .= toJSON atomtype,

@@ -122,6 +132,7 @@ instance FromJSON Atom where

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

123133 Right bs -> pure (ByteStringAtom bs)

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

135+ RelationalExprAtomType -> RelationalExprAtom <$> o .: "val"

125136

126137instance ToJSON Notification

127138instance FromJSON Notification

@@ -129,6 +140,21 @@ instance FromJSON Notification

129140instance ToJSON ScriptCompilationError

130141instance FromJSON ScriptCompilationError

131142

143+instance ToJSON MerkleHash where

144+ toJSON h = object [ "merklehash" .= decodeUtf8 (B64.encode (_unMerkleHash h))]

145+instance FromJSON MerkleHash where

146+ parseJSON = withObject "merklehash" $ \o -> do

147+ b64bs <- encodeUtf8 <$> o .: "merklehash"

148+ case B64.decode b64bs of

149+ Left err -> fail ("Failed to parse merkle hash: " ++ err)

150+ Right bs -> pure (MerkleHash bs)

151+

152+instance ToJSON Attributes where

153+ toJSON attrs = object ["attributes" .= map toJSON (A.toList attrs)]

154+instance FromJSON Attributes where

155+ parseJSON = withObject "Attributes" $ \o ->

156+ A.attributesFromList <$> o .: "attributes"

157+

132158instance ToJSON RelationalError

133159instance FromJSON RelationalError

134160

@@ -138,6 +164,9 @@ instance FromJSON SchemaError

138164instance ToJSON MergeError

139165instance FromJSON MergeError

140166

167+instance ToJSON ImportError'

168+instance FromJSON ImportError'

169+

141170instance ToJSON DatabaseContextFunctionError

142171instance FromJSON DatabaseContextFunctionError

143172

@@ -152,3 +181,5 @@ instance FromJSON AtomFunctionError

152181

153182instance ToJSON WithNameExpr

154183instance FromJSON WithNameExpr

184+

185+

src/bin/ProjectM36/Server/WebSocket.hs+33−21

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

1−{-# LANGUAGE LambdaCase #-}

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

22module ProjectM36.Server.WebSocket where

33-- while the tutd client performs TutorialD parsing on the client, the websocket server will pass tutd to be parsed and executed on the server- otherwise I have to pull in ghcjs as a dependency to allow client-side parsing- that's not appealing because then the frontend is not language-agnostic, but this could change in the future, perhaps by sending different messages over the websocket

44-- ideally, the wire protocol should not be exposed to a straight string-based API ala SQL, so we could make perhaps a javascript DSL which compiles to the necessary JSON- anaylyze tradeoffs

@@ -22,9 +22,14 @@ import Data.Attoparsec.Text

2222import Control.Applicative

2323import Text.Megaparsec.Error

2424import Data.Functor

25+import Data.Either (fromRight)

26+

27+#if MIN_VERSION_megaparsec(7,0,0)

28+import Data.List.NonEmpty as NE

29+#endif

2530

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

27−websocketProxyServer port host pending = do

32+websocketProxyServer port host pending = do

2833 conn <- WS.acceptRequest pending

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

3035 --phase 1- accept database name for connection

@@ -33,10 +38,10 @@ websocketProxyServer port host pending = do

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

3439 else do

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

36− bracket (createConnection conn dbname port host)

41+ bracket (createConnection conn dbname port host)

3742 (\case

3843 Right dbconn -> close dbconn

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

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

4045 Left err -> sendError conn err

4146 Right dbconn -> do

4247 eSessionId <- createSessionAtHead dbconn "master"

@@ -47,34 +52,41 @@ websocketProxyServer port host pending = do

4752 _ <- forever $ do

4853 pInfo <- promptInfo sessionId dbconn

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

50− sendPromptInfo pInfo conn

55+ sendPromptInfo pInfo conn

5156 sendPromptInfo pInfo conn

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

5358 case parseOnly parseExecuteMessage msg of

5459 Left _ -> unexpectedMsg

5560 Right (presentation, tutdString) ->

5661 case parseTutorialD tutdString of

57− Left err -> handleOpResult conn dbconn presentation (DisplayErrorResult ("parse error: " `T.append` T.pack (parseErrorPretty err)))

62+ Left err -> handleOpResult conn dbconn presentation

63+#if MIN_VERSION_megaparsec(7,0,0)

64+ (DisplayErrorResult

65+ ("parse error: " `T.append` T.pack

66+ (parseErrorPretty . NE.head . bundleErrors $ err)))

67+#else

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

69+#endif

5870 Right parsed -> do

59− let timeoutFilter exc = if exc == RequestTimeoutException

60− then Just exc

71+ let timeoutFilter exc = if exc == RequestTimeoutException

72+ then Just exc

6173 else Nothing

6274 responseHandler = do

6375 result <- evalTutorialD sessionId dbconn SafeEvaluation parsed

6476 pInfo' <- promptInfo sessionId dbconn

65− sendPromptInfo pInfo' conn

77+ sendPromptInfo pInfo' conn

6678 handleOpResult conn dbconn presentation result

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

6880 pure ()

69−

70−notificationCallback :: WS.Connection -> NotificationCallback

81+

82+notificationCallback :: WS.Connection -> NotificationCallback

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

7284 "evaldnotification" .= evaldNotif

7385 ]))

74−

86+

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

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

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

89+createConnection wsconn dbname port host = connectProjectM36 (RemoteConnectionInfo dbname host (show port) (notificationCallback wsconn))

7890

7991sendError :: (ToJSON a) => WS.Connection -> a -> IO ()

8092sendError conn err = WS.sendTextData conn (encode (object ["displayerror" .= err]))

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

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

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

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

103−

115+

104116-- get current schema and head name for client

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

106118promptInfo sessionId conn = do

107− eHeadName <- headName sessionId conn

119+ eHeadName <- headName sessionId conn

108120 eSchemaName <- currentSchemaName sessionId conn

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

110−

121+ pure (fromRight "<unknown>" eHeadName, fromRight "<no schema>" eSchemaName)

122+

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

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

113125

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

115127data Presentation = Presentation {

116− jsonPresentation :: Bool,

128+ jsonPresentation :: Bool,

117129 textPresentation :: Bool,

118130 htmlPresentation :: Bool }

119−

131+

120132data PresentationFlag = JSONFlag | TextFlag | HTMLFlag

121−

133+

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

123135parseExecuteMessage = do

124136 _ <- string "executetutd/"

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

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

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

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

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

129141 JSONFlag -> acc {jsonPresentation = True}

130142 TextFlag -> acc {textPresentation = True}

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

src/bin/ProjectM36/Server/WebSocket/websocket-client.html+1−1

@@ -126,7 +126,7 @@ margin-bottom: 5pt;

126126 <li>:showrelvars</li>

127127 <li>:showexpr true</li>

128128 <li>:showexpr false</li>

129− <li>:importexample date</li>

129+ <li>:importexample cjdate</li>

130130 <li>:showexpr s join sp</li>

131131 <li>update s where city="Paris" (status:=10)</li>

132132 <li>:showexpr s</li>

src/bin/ProjectM36/Server/WebSocket/websocket-server.hs+48−18

@@ -1,33 +1,63 @@

11{-# LANGUAGE CPP #-}

2−import ProjectM36.Server.WebSocket

3−import ProjectM36.Server.Config

4−import ProjectM36.Server.ParseArgs

5−import ProjectM36.Server

6−import Control.Concurrent

7−import qualified Network.WebSockets as WS

8−

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

10−import Network.Transport.TCP.Internal (decodeEndPointAddress)

11−#else

12−import Network.Transport.TCP (decodeEndPointAddress)

13−#endif

142

3+import Control.Concurrent

154import Control.Exception

5+import Control.Monad (when)

6+import Data.Maybe (isJust)

7+import Data.String (fromString)

8+import Network.HTTP.Types (status400)

9+import Network.Socket

10+import Network.Wai (Application, responseLBS)

11+import Network.Wai.Handler.Warp

12+import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings)

13+import qualified Network.Wai.Handler.WebSockets as WS

14+import Network.WebSockets (defaultConnectionOptions)

15+import ProjectM36.Server

16+import ProjectM36.Server.Config

17+import ProjectM36.Server.ParseArgs

18+import ProjectM36.Server.WebSocket

1619

1720main :: IO ()

1821main = do

1922 -- launch normal project-m36-server

2023 addressMVar <- newEmptyMVar

21− serverConfig <- parseConfigWithDefaults (defaultServerConfig { bindPort = 8000, bindHost = "127.0.0.1" })

24+ wsConfig <- parseWSConfigWithDefaults (defaultServerConfig {bindPort = 8000, bindHost = "127.0.0.1"})

25+

2226 --usurp the serverConfig for our websocket server and make the proxied server run locally

23− let wsHost = bindHost serverConfig

27+ let serverConfig = wsServerConfig wsConfig

28+ wsHost = bindHost serverConfig

2429 wsPort = bindPort serverConfig

2530 serverHost = "127.0.0.1"

2631 serverConfig' = serverConfig {bindPort = 0, bindHost = serverHost}

32+ configCertificateFile = tlsCertificatePath wsConfig

33+ configKeyFile = tlsKeyPath wsConfig

34+

35+ when (isJust configCertificateFile /= isJust configKeyFile) $

36+ throwIO $ ErrorCall "TLS_CERTIFICATE_PATH and TLS_KEY_PATH must be set in tandem"

37+

2738 _ <- forkFinally (launchServer serverConfig' (Just addressMVar) >> pure ()) (either throwIO pure)

2839 --wait for server to be listening

29− address <- takeMVar addressMVar

30− let Just (_, serverPort, _) = decodeEndPointAddress address

31− --this built-in server is apparently not meant for production use, but it's easier to test than starting up the wai or snap interfaces

32− WS.runServer wsHost (fromIntegral wsPort) (websocketProxyServer (read serverPort) serverHost)

40+ addr <- takeMVar addressMVar

41+ let port =

42+ case addr of

43+ SockAddrInet port' _ -> fromIntegral port'

44+ _ -> error "unsupported socket address (IPv4 only currently)"

45+ wsApp = websocketProxyServer port serverHost

46+ waiApp = WS.websocketsOr defaultConnectionOptions wsApp backupApp

47+ settings = warpSettings wsHost (fromIntegral wsPort)

48+

49+ case (configCertificateFile, configKeyFile) of

50+ (Just certificate, Just key) -> runTLS (tlsSettings certificate key) settings waiApp

51+ _ -> runSettings settings waiApp

52+

53+backupApp :: Application

54+backupApp _ respond = respond $ responseLBS status400 [] "Not a WebSocket request"

3355

56+warpSettings :: HostName -> Port -> Settings

57+warpSettings host port =

58+ setHost (fromString host)

59+ . setPort port

60+ . setServerName "project-m36"

61+ . setTimeout 3600

62+ . setGracefulShutdownTimeout (Just 5)

63+ $ defaultSettings

src/bin/TutorialD/Interpreter.hs+30−28

@@ -28,12 +28,13 @@ import System.Console.Haskeline

2828import System.Directory (getHomeDirectory)

2929import qualified Data.Text as T

3030import System.IO (hPutStrLn, stderr)

31−#if __GLASGOW_HASKELL__ <= 802

31+#if __GLASGOW_HASKELL__ < 804

3232import Data.Monoid

3333#endif

3434import Data.List (isPrefixOf)

3535import Control.Exception

3636import System.Exit

37+import Data.Either (fromRight)

3738

3839{-

3940context ops are read-only operations which only operate on the database context (relvars and constraints)

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

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

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

6364 fmap DatabaseContextIOExprOp (dbContextIOExprP <* eof)

64−

65+

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

6667safeInterpreterParserP :: Parser ParsedOperation

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

@@ -77,8 +78,8 @@ safeInterpreterParserP = fmap RODatabaseContextOp (roDatabaseContextOperatorP <*

7778promptText :: Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType

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

7980 where

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

81−

81+ transInfo = fromRight "<unknown>" eHeadName <> "/" <> fromRight "<no schema>" eSchemaName

82+

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

8384parseTutorialD = parse interpreterParserP ""

8485

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

106107 else

107108 pure res

108109 _ -> pure res

109−

110− (DatabaseContextExprOp execOp) ->

111− eHandler $ C.executeDatabaseContextExpr sessionId conn execOp

112−

113− (DatabaseContextIOExprOp execOp) ->

110+

111+ (DatabaseContextExprOp execOp) ->

112+ eHandler $ C.executeDatabaseContextExpr sessionId conn execOp

113+

114+ (DatabaseContextIOExprOp execOp) ->

114115 if needsSafe then

115116 unsafeError

116117 else

117118 eHandler $ C.executeDatabaseContextIOExpr sessionId conn execOp

118−

119+

119120 (GraphOp execOp) -> do

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

121122 eIsDirty <- C.disconnectedTransactionIsDirty sessionId conn

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

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

123124 settings = Settings {complete = noCompletion,

124125 historyFile = Nothing,

125126 autoAddHistory = False}

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

143144 pure (DisplayErrorResult "Graph operation cancelled.")

144145 else

145146 runGraphOp

146−

147+

147148 (ConvenienceGraphOp execOp) ->

148149 eHandler $ evalConvenienceGraphOp sessionId conn execOp

149150

150151 (ROGraphOp execOp) -> do

151152 opResult <- evalROGraphOp sessionId conn execOp

152− case opResult of

153+ case opResult of

153154 Left err -> barf err

154155 Right rel -> pure (DisplayRelationResult rel)

155−

156+

156157 (SchemaOp execOp) ->

157158 eHandler $ evalSchemaOperator sessionId conn execOp

158−

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

159+

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

160161 if needsSafe then

161162 unsafeError

162163 else do

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

174175 case exprErr of

175176 Left err -> barf err

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

177−

178− (ImportDBContextOp execOp) ->

178+

179+ (ImportDBContextOp execOp) ->

179180 if needsSafe then

180181 unsafeError

181182 else do

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

183184 case eErr of

184185 Left err -> barf err

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

186−

187− (InfoOp execOp) ->

187+

188+ (InfoOp execOp) ->

188189 if needsSafe then

189190 unsafeError

190191 else

191192 case evalInformationOperator execOp of

192193 Left err -> pure (DisplayErrorResult err)

193194 Right info -> pure (DisplayResult info)

194−

195+

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

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

197198 if needsSafe then

@@ -215,19 +216,20 @@ evalTutorialDInteractive sessionId conn safe interactive expr = case expr of

215216 unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited."

216217 barf :: RelationalError -> IO TutorialDOperatorResult

217218 barf (ScriptError (OtherScriptCompilationError errStr)) = pure (DisplayErrorResult (T.pack errStr))

219+ barf (ParseError err) = pure (DisplayErrorResult err)

218220 barf err = return $ DisplayErrorResult (T.pack (show err))

219221 eHandler io = do

220222 eErr <- io

221223 case eErr of

222224 Left err -> barf err

223225 Right () -> return QuietSuccessResult

224−

225−type GhcPkgPath = String

226+

227+type GhcPkgPath = String

226228type TutorialDExec = String

227229type CheckFS = Bool

228−

230+

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

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

232+ RemoteInterpreterConfig C.Hostname C.Port C.DatabaseName HeadName (Maybe TutorialDExec) CheckFS

231233

232234outputNotificationCallback :: C.NotificationCallback

233235outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received " ++ show notName ++ ":\n" ++ "\n" ++ prettyEvaluatedNotification evaldNot

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

256258 Just line -> do

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

258260 reprLoop config sessionId conn

259−

261+

260262

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

262−runTutorialD sessionId conn mPromptLength tutd =

264+runTutorialD sessionId conn mPromptLength tutd =

263265 case parseTutorialD tutd of

264− Left err ->

266+ Left err ->

265267 displayOpResult $ DisplayParseErrorResult mPromptLength err

266268 Right parsed ->

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

src/bin/TutorialD/Interpreter/Base.hs+66−38

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

11{-# LANGUAGE DeriveGeneric, CPP #-}

22module TutorialD.Interpreter.Base (

3− module TutorialD.Interpreter.Base,

3+ module TutorialD.Interpreter.Base,

44 module Text.Megaparsec,

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

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

66 module Text.Megaparsec.Char,

77 module Control.Applicative

88#else

@@ -12,11 +12,12 @@ module TutorialD.Interpreter.Base (

1212 where

1313import ProjectM36.Base

1414import ProjectM36.AtomType

15+import ProjectM36.Attribute as A

1516import ProjectM36.Relation

1617import ProjectM36.DataFrame

1718

1819#if MIN_VERSION_megaparsec(6,0,0)

19−import Text.Megaparsec.Char

20+import Text.Megaparsec.Char

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

2122import Text.Megaparsec

2223import Data.Void

@@ -30,12 +31,11 @@ import Data.Text hiding (count)

3031import System.Random

3132import qualified Data.Text as T

3233import qualified Data.List as L

33−import qualified Data.Vector as V

3434import qualified Data.Text.IO as TIO

3535import System.IO

3636import ProjectM36.Relation.Show.Term

3737import GHC.Generics

38−#if __GLASGOW_HASKELL__ <= 802

38+#if __GLASGOW_HASKELL__ < 804

3939import Data.Monoid

4040#endif

4141import qualified Data.UUID as U

@@ -44,12 +44,18 @@ import Data.List.NonEmpty as NE

4444import Data.Time.Clock

4545import Data.Time.Format

4646import Control.Monad (void)

47+import Data.Char

48+

49+#if !MIN_VERSION_megaparsec(7,0,0)

50+anySingle :: Parsec Void Text (Token Text)

51+anySingle = anyChar

52+#endif

4753

4854displayOpResult :: TutorialDOperatorResult -> IO ()

4955displayOpResult QuitResult = return ()

5056displayOpResult (DisplayResult out) = TIO.putStrLn out

5157displayOpResult (DisplayIOResult ioout) = ioout

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

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

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

5460displayOpResult QuietSuccessResult = return ()

5561displayOpResult (DisplayRelationResult rel) = do

@@ -57,8 +63,13 @@ displayOpResult (DisplayRelationResult rel) = do

5763 let randomlySortedRel = evalRand (randomizeTupleOrder rel) gen

5864 TIO.putStrLn (showRelation randomlySortedRel)

5965displayOpResult (DisplayParseErrorResult mPromptLength err) = do

60− let errString = T.pack (parseErrorPretty err)

61− errorIndent = unPos (sourceColumn (NE.head (errorPos err)))

66+#if MIN_VERSION_megaparsec(7,0,0)

67+ let errorIndent = errorOffset . NE.head . bundleErrors $ err

68+ errString = T.pack (parseErrorPretty . NE.head . bundleErrors $ err)

69+#else

70+ let errorIndent = unPos (sourceColumn (NE.head (errorPos err)))

71+ errString = T.pack (parseErrorPretty err)

72+#endif

6273 pointyString len = T.justifyRight (len + fromIntegral errorIndent) '_' "^"

6374 maybe (pure ()) (TIO.putStrLn . pointyString) mPromptLength

6475 TIO.putStr ("ERR:" <> errString)

@@ -71,9 +82,10 @@ type ParseStr = Text

7182type ParseStr = String

7283#endif

7384

85+-- consumes only horizontal spaces

7486spaceConsumer :: Parser ()

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

76−

87+spaceConsumer = Lex.space space1 (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}")

88+

7789opChar :: Parser Char

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

7991

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

92104identifier :: Parser Text

93105identifier = do

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

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

107+ identifierRemainder istart

108+

109+identifierRemainder :: Char -> Parser Text

110+identifierRemainder c = do

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

96112 spaceConsumer

97− pure (pack (istart:irest))

113+ pure (pack (c:rest))

98114

99115symbol :: ParseStr -> Parser Text

100116#if MIN_VERSION_megaparsec(6,0,0)

@@ -121,11 +137,14 @@ arrow = symbol "->"

121137semi :: Parser Text

122138semi = symbol ";"

123139

140+nline :: Parser Text

141+nline = (T.singleton <$> newline) <|> crlf

142+

124143integer :: Parser Integer

125144#if MIN_VERSION_megaparsec(6,0,0)

126−integer = Lex.signed spaceConsumer Lex.decimal

145+integer = Lex.signed (pure ()) Lex.decimal <* spaceConsumer

127146#else

128−integer = Lex.signed spaceConsumer Lex.integer

147+integer = Lex.signed (pure ()) Lex.integer <* spaceConsumer

129148#endif

130149

131150natural :: Parser Integer

@@ -136,36 +155,30 @@ natural = Lex.integer <* spaceConsumer

136155#endif

137156

138157float :: Parser Double

139−float = Lex.float

158+float = Lex.float <* spaceConsumer

140159

141160capitalizedIdentifier :: Parser Text

142−capitalizedIdentifier = do

143− fletter <- upperChar

144− restOfIdentifier_ fletter

145−

146−restOfIdentifier_ :: Char -> Parser Text

147−restOfIdentifier_ fletter = do

148− rest <- option "" identifier

149− spaceConsumer

150− pure (T.cons fletter rest)

151−

161+capitalizedIdentifier =

162+ upperChar >>= identifierRemainder

163+

152164uncapitalizedIdentifier :: Parser Text

153−uncapitalizedIdentifier = do

154− fletter <- lowerChar

155− restOfIdentifier_ fletter

165+uncapitalizedIdentifier =

166+ lowerChar >>= identifierRemainder

156167

157168showRelationAttributes :: Attributes -> Text

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

159170 where

160− showAttribute (Attribute name atomType) = name <> " " <> prettyAtomType atomType

161− attrsL = V.toList attrs

171+ showAttribute (Attribute name atomType') = name <> " " <> prettyAtomType atomType'

172+ attrsL = A.toList attrs

162173

163−type PromptLength = Int

174+type PromptLength = Int

164175

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

176+#if MIN_VERSION_megaparsec(7,0,0)

177+type ParserError = ParseErrorBundle T.Text Void

178+#elif MIN_VERSION_megaparsec(6,0,0)

166179type ParserError = ParseError Char Void

167−#else

168−type ParserError = ParseError Char Dec

180+#else

181+type ParserError = ParseError Char Dec

169182#endif

170183

171184data TutorialDOperatorResult = QuitResult |

@@ -177,24 +190,27 @@ data TutorialDOperatorResult = QuitResult |

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

178191 QuietSuccessResult

179192 deriving (Generic)

180−

193+

181194type TransactionGraphWasUpdated = Bool

182195

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

184197tripleQuotedString :: Parser Text

185198tripleQuotedString = do

186199 _ <- tripleQuote

187− pack <$> manyTill anyChar (try (tripleQuote >> notFollowedBy quote))

188−

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

201+

189202normalQuotedString :: Parser Text

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

191204

192205quotedString :: Parser Text

193206quotedString = try tripleQuotedString <|> normalQuotedString

194207

208+quoted :: Parser a -> Parser a

209+quoted = between quote quote

210+

195211uuidP :: Parser U.UUID

196212uuidP = do

197− uuidStart <- count 8 hexDigitChar

213+ uuidStart <- count 8 hexDigitChar

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

199215 uuidMid1 <- count 4 hexDigitChar

200216 _ <- char '-'

@@ -214,4 +230,16 @@ utcTimeP = do

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

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

216232 Just stamp' -> pure stamp'

233+

234+

235+colonOp :: Text -> Parser ()

236+colonOp opStr = do

237+ _ <- string opStr <* (void spaceChar <|> eof) <* spaceConsumer

238+ pure ()

239+

240+hex :: Parser Text

241+hex = takeWhileP (Just "hexadecimal")

242+ (\c ->

243+ isDigit c

244+ || (c >= 'a' && c <= 'f'))

217245

src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+16−13

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

1212import qualified ProjectM36.RelationalExpression as RE

1313import ProjectM36.Key

1414import ProjectM36.FunctionalDependency

15−#if __GLASGOW_HASKELL__ <= 802

15+#if __GLASGOW_HASKELL__ < 804

1616import Data.Monoid

1717#endif

1818import Data.Functor

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

4444assignP :: Parser DatabaseContextExpr

4545assignP = do

4646 relVarName <- try $ do

47− relVarName <- identifier

47+ relVarName <- relVarNameP

4848 reservedOp ":="

4949 return relVarName

5050 Assign relVarName <$> relExprP

@@ -53,19 +53,20 @@ multilineSep :: Parser T.Text

5353multilineSep = newline >> pure "\n"

5454

5555multipleDatabaseContextExprP :: Parser DatabaseContextExpr

56−multipleDatabaseContextExprP =

57− MultipleExpr <$> sepBy1 databaseContextExprP semi

56+multipleDatabaseContextExprP = do

57+ exprs <- filter (/= NoOperation) <$> sepBy1 databaseContextExprP semi

58+ pure (MultipleExpr exprs)

5859

5960insertP :: Parser DatabaseContextExpr

6061insertP = do

6162 reservedOp "insert"

62− relvar <- identifier

63+ relvar <- relVarNameP

6364 Insert relvar <$> relExprP

6465

6566defineP :: Parser DatabaseContextExpr

6667defineP = do

6768 relVarName <- try $ do

68− relVarName <- identifier

69+ relVarName <- relVarNameP

6970 reservedOp "::"

7071 return relVarName

7172 Define relVarName <$> makeAttributeExprsP

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

7374undefineP :: Parser DatabaseContextExpr

7475undefineP = do

7576 reservedOp "undefine"

76− Undefine <$> identifier

77+ Undefine <$> relVarNameP

7778

7879deleteP :: Parser DatabaseContextExpr

7980deleteP = do

8081 reservedOp "delete"

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

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

8283

8384updateP :: Parser DatabaseContextExpr

8485updateP = do

8586 reservedOp "update"

86− relVarName <- identifier

87+ relVarName <- relVarNameP

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

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

8990 return $ Update relVarName attributeAssignments predicate

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

166167removeTypeConstructorP :: Parser DatabaseContextExpr

167168removeTypeConstructorP = do

168169 reserved "undata"

169− RemoveTypeConstructor <$> identifier

170+ RemoveTypeConstructor <$> typeConstructorNameP

170171

171172removeAtomFunctionP :: Parser DatabaseContextExpr

172173removeAtomFunctionP = do

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

178179 reserved "removedatabasecontextfunction"

179180 RemoveDatabaseContextFunction <$> quotedString

180181

182+functionNameP :: Parser AtomFunctionName

183+functionNameP = uncapitalizedIdentifier

184+

181185executeDatabaseContextFunctionP :: Parser DatabaseContextExpr

182186executeDatabaseContextFunctionP = do

183187 reserved "execute"

184− funcName <- identifier

188+ funcName <- functionNameP

185189 args <- parens (sepBy atomExprP comma)

186190 pure (ExecuteDatabaseContextFunction funcName args)

187191

@@ -203,8 +207,7 @@ interpretDatabaseContextExpr context transId graph tutdstring =

203207 Left err -> Left $ PM36E.ParseError (T.pack (show err))

204208 Right parsed -> do

205209 let env = RE.mkDatabaseContextEvalEnv transId graph

206− x <- RE.dbc_context <$> RE.runDatabaseContextEvalMonad context env (optimizeAndEvalDatabaseContextExpr True parsed)

207− pure x

210+ RE.dbc_context <$> RE.runDatabaseContextEvalMonad context env (optimizeAndEvalDatabaseContextExpr True parsed)

208211

209212{-

210213--no optimization

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

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

22module TutorialD.Interpreter.Export.Base where

33import ProjectM36.Base

44import ProjectM36.Error

5−#if __GLASGOW_HASKELL__ <= 802

5+#if __GLASGOW_HASKELL__ < 804

66import Data.Monoid

77#endif

src/bin/TutorialD/Interpreter/Import/Base.hs+9−4

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

22module TutorialD.Interpreter.Import.Base where

33import ProjectM36.Base

44import ProjectM36.Error

5−#if __GLASGOW_HASKELL__ <= 802

5+import Text.URI (URI)

6+import Data.Text (Text)

7+#if __GLASGOW_HASKELL__ < 804

68import Data.Monoid

79#endif

810

@@ -12,11 +14,14 @@ data RelVarDataImportOperator = RelVarDataImportOperator RelVarName FilePath (Re

1214instance Show RelVarDataImportOperator where

1315 show (RelVarDataImportOperator rv path _) = "RelVarDataImportOperator " <> show rv <> " " <> path

1416

17+type HashVerification = Maybe Text

18+

1519-- | import data into a database context

16−data DatabaseContextDataImportOperator = DatabaseContextDataImportOperator FilePath (FilePath -> IO (Either RelationalError DatabaseContextExpr))

20+data DatabaseContextDataImportOperator = DatabaseContextDataImportOperator URI HashVerification (URI -> HashVerification -> IO (Either RelationalError DatabaseContextExpr))

1721

1822instance Show DatabaseContextDataImportOperator where

19− show (DatabaseContextDataImportOperator path _) = "DatabaseContextDataImportOperator " <> path

23+ show (DatabaseContextDataImportOperator uri hash _) =

24+ "DatabaseContextDataImportOperator " <> show uri <> " " <> show hash

2025

2126-- perhaps create a structure to import a whole transaction graph section in the future

2227

@@ -24,4 +29,4 @@ evalRelVarDataImportOperator :: RelVarDataImportOperator -> TypeConstructorMappi

2429evalRelVarDataImportOperator (RelVarDataImportOperator relVarName path importFunc) tConsMap attrs = importFunc relVarName tConsMap attrs path

2530

2631evalDatabaseContextDataImportOperator :: DatabaseContextDataImportOperator -> IO (Either RelationalError DatabaseContextExpr)

27−evalDatabaseContextDataImportOperator (DatabaseContextDataImportOperator path importFunc) = importFunc path

32+evalDatabaseContextDataImportOperator (DatabaseContextDataImportOperator uri hash importFunc) = importFunc uri hash

src/bin/TutorialD/Interpreter/Import/BasicExamples.hs+2−2

@@ -20,8 +20,8 @@ importBasicExampleOperatorP :: Parser ImportBasicExampleOperator

2020importBasicExampleOperatorP = do

2121 reservedOp ":importexample"

2222 example <- identifier

23− if example == "date" then

23+ if example == "cjdate" then

2424 pure ImportBasicDateExampleOperator

2525 else

2626 fail "Unknown example name"

27−

27+

src/bin/TutorialD/Interpreter/Import/CSV.hs+3−3

@@ -14,10 +14,10 @@ importCSVRelation relVarName tConsMap attrs pathIn = do

1414 --TODO: handle filesystem errors

1515 csvData <- try (BS.readFile pathIn) :: IO (Either IOError BS.ByteString)

1616 case csvData of

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

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

1818 Right csvData' -> case csvAsRelation attrs tConsMap csvData' of

19− Left err -> return $ Left (ParseError $ T.pack (show err))

20− Right csvRel -> return $ Right (Insert relVarName (ExistingRelation csvRel))

19+ Left err -> pure $ Left (ParseError $ T.pack (show err))

20+ Right csvRel -> pure $ Right (Insert relVarName (ExistingRelation csvRel))

2121

2222importCSVP :: Parser RelVarDataImportOperator

2323importCSVP = do

src/bin/TutorialD/Interpreter/Import/TutorialD.hs+70−17

@@ -9,25 +9,78 @@ import qualified Data.Text as T

99import Control.Exception

1010import qualified Data.ByteString as BS

1111import qualified Data.Text.Encoding as TE

12−--import a file containing TutorialD database context expressions

12+import qualified Text.URI as URI

13+import Text.URI (URI)

14+import Crypto.Hash.SHA256

15+import Data.ByteString.Base16 as B16

16+import Network.HTTP.Simple

17+import Network.HTTP.Types

18+--import a file containing TutorialD database context expressions via local files or HTTP/HTTPS

1319

14−importTutorialD :: FilePath -> IO (Either RelationalError DatabaseContextExpr)

15−importTutorialD pathIn = do

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

17− case eTutdBytes of

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

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−

20+importTutorialDFromFile :: URI -> HashVerification -> IO (Either RelationalError DatabaseContextExpr)

21+importTutorialDFromFile fileURI mHash = do

22+ case URI.uriPath fileURI of

23+ Just (False, _) -> do

24+ eTutdBytes <- try (BS.readFile filePath) :: IO (Either IOError BS.ByteString)

25+ case eTutdBytes of

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

27+ Right tutdBytes ->

28+ case validateBytes tutdBytes mHash of

29+ Left err -> pure (Left err)

30+ Right tutdBytes' -> importTutorialDBytes tutdBytes'

31+ _ -> pure (Left (ImportError (InvalidFileURIError (URI.render fileURI))))

32+ where

33+ filePath = drop (length ("file://" :: String)) (URI.renderStr fileURI)

34+

35+

36+importTutorialDBytes :: BS.ByteString -> IO (Either RelationalError DatabaseContextExpr)

37+importTutorialDBytes tutdBytes =

38+ case TE.decodeUtf8' tutdBytes of

39+ Left err -> pure (Left (ImportError (ImportFileDecodeError (T.pack (show err)))))

40+ Right tutdUtf8 ->

41+ case parse (multipleDatabaseContextExprP <* eof) "import" tutdUtf8 of

42+ --parseErrorPretty is new in megaparsec 5

43+ Left err -> pure (Left (PM36E.ParseError (T.pack (errorBundlePretty err))))

44+ Right expr -> pure (Right expr)

45+

46+importTutorialDViaHTTP :: URI -> HashVerification -> IO (Either RelationalError DatabaseContextExpr)

47+importTutorialDViaHTTP uri mHash = do

48+ reqURI <- parseRequest (URI.renderStr uri)

49+ response <- httpBS reqURI

50+ let scode = getResponseStatus response

51+ if scode == ok200 then

52+ let byteBody = getResponseBody response in

53+ case validateBytes byteBody mHash of

54+ Right byteBody' -> do

55+ importTutorialDBytes byteBody'

56+ Left err -> pure (Left err)

57+ else

58+ pure (Left (ImportError (ImportDownloadError (T.pack ("download failed: " <> show scode)))))

59+

60+validateBytes :: BS.ByteString -> HashVerification -> Either RelationalError BS.ByteString

61+validateBytes tutdBytes mHash =

62+ case mHash of

63+ Nothing -> pure tutdBytes

64+ Just expectedHashText ->

65+ case B16.decode (TE.encodeUtf8 expectedHashText) of

66+ Left _ -> Left (ImportError (InvalidSHA256Error expectedHashText))

67+ Right expectedHash | hashBytes == expectedHash -> pure tutdBytes

68+ | otherwise ->

69+ let p = TE.decodeUtf8 . B16.encode in

70+ Left (ImportError (SHA256MismatchError (p expectedHash) (p hashBytes)))

71+ where

72+ hashBytes = hash tutdBytes

73+

74+

2875tutdImportP :: Parser DatabaseContextDataImportOperator

2976tutdImportP = do

3077 reserved ":importtutd"

31− path <- quotedString

78+ uri <- quoted URI.parser

3279 spaceConsumer

33− return $ DatabaseContextDataImportOperator (T.unpack path) importTutorialD

80+ mhash <- optional (quoted hex)

81+ handler <- case URI.unRText <$> URI.uriScheme uri of

82+ Nothing -> fail "URI scheme missing"

83+ Just "file" -> pure importTutorialDFromFile

84+ Just scheme | scheme `elem` ["http", "https"] -> pure importTutorialDViaHTTP

85+ | otherwise -> fail ( "unsupported URI scheme: " <> show scheme)

86+ pure $ DatabaseContextDataImportOperator uri mhash handler

src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs+33−16

@@ -1,13 +1,16 @@

11{-# LANGUAGE GADTs #-}

22module TutorialD.Interpreter.RODatabaseContextOperator where

33import ProjectM36.Base

4+import ProjectM36.Relation

45import qualified ProjectM36.DataFrame as DF

56import ProjectM36.Error

7+import ProjectM36.Tuple

68import ProjectM36.InclusionDependency

79import qualified ProjectM36.Client as C

810import TutorialD.Interpreter.Base

911import TutorialD.Interpreter.RelationalExpr

1012import TutorialD.Interpreter.DatabaseContextExpr

13+import TutorialD.Printer

1114import Control.Monad.State

1215import qualified Data.Text as T

1316import ProjectM36.Relation.Show.Gnuplot

@@ -19,7 +22,7 @@ data RODatabaseContextOperator where

1922 ShowRelation :: RelationalExpr -> RODatabaseContextOperator

2023 PlotRelation :: RelationalExpr -> RODatabaseContextOperator

2124 ShowRelationType :: RelationalExpr -> RODatabaseContextOperator

22− ShowConstraint :: StringType -> RODatabaseContextOperator

25+ ShowConstraints :: StringType -> RODatabaseContextOperator

2326 ShowPlan :: DatabaseContextExpr -> RODatabaseContextOperator

2427 ShowTypes :: RODatabaseContextOperator

2528 ShowRelationVariables :: RODatabaseContextOperator

@@ -31,44 +34,44 @@ data RODatabaseContextOperator where

3134

3235typeP :: Parser RODatabaseContextOperator

3336typeP = do

34− reservedOp ":type"

37+ colonOp ":type"

3538 ShowRelationType <$> relExprP

3639

3740showRelP :: Parser RODatabaseContextOperator

3841showRelP = do

39− reservedOp ":showexpr"

42+ colonOp ":showexpr"

4043 ShowRelation <$> relExprP

4144

4245showPlanP :: Parser RODatabaseContextOperator

4346showPlanP = do

44− reservedOp ":showplan"

47+ colonOp ":showplan"

4548 ShowPlan <$> databaseContextExprP

4649

4750showTypesP :: Parser RODatabaseContextOperator

48−showTypesP = reserved ":showtypes" >> pure ShowTypes

51+showTypesP = colonOp ":showtypes" >> pure ShowTypes

4952

5053showRelationVariables :: Parser RODatabaseContextOperator

51−showRelationVariables = reserved ":showrelvars" >> pure ShowRelationVariables

54+showRelationVariables = colonOp ":showrelvars" >> pure ShowRelationVariables

5255

5356showAtomFunctionsP :: Parser RODatabaseContextOperator

54−showAtomFunctionsP = reserved ":showatomfunctions" >> pure ShowAtomFunctions

57+showAtomFunctionsP = colonOp ":showatomfunctions" >> pure ShowAtomFunctions

5558

5659showDatabaseContextFunctionsP :: Parser RODatabaseContextOperator

57−showDatabaseContextFunctionsP = reserved ":showdatabasecontextfunctions" >> pure ShowDatabaseContextFunctions

60+showDatabaseContextFunctionsP = colonOp ":showdatabasecontextfunctions" >> pure ShowDatabaseContextFunctions

5861

5962quitP :: Parser RODatabaseContextOperator

6063quitP = do

61− reservedOp ":quit"

64+ colonOp ":quit"

6265 return Quit

6366

6467showConstraintsP :: Parser RODatabaseContextOperator

6568showConstraintsP = do

66− reservedOp ":constraints"

67− ShowConstraint <$> option "" identifier

69+ colonOp ":constraints"

70+ ShowConstraints <$> option "" identifier

6871

6972plotRelExprP :: Parser RODatabaseContextOperator

7073plotRelExprP = do

71− reserved ":plotexpr"

74+ colonOp ":plotexpr"

7275 PlotRelation <$> relExprP

7376

7477roDatabaseContextOperatorP :: Parser RODatabaseContextOperator

@@ -106,15 +109,16 @@ evalRODatabaseContextOp sessionId conn (PlotRelation expr) = do

106109 err <- plotRelation rel

107110 when (isJust err) $ print err

108111

109−evalRODatabaseContextOp sessionId conn (ShowConstraint name) = do

112+evalRODatabaseContextOp sessionId conn (ShowConstraints name) = do

110113 eIncDeps <- C.inclusionDependencies sessionId conn

111114 let val = case eIncDeps of

112115 Left err -> Left err

113116 Right incDeps -> case name of

114− "" -> inclusionDependenciesAsRelation incDeps

117+ "" -> inclusionDependenciesAsRelation incDeps >>= renderRelExprsInIncDeps

115118 depName -> case M.lookup depName incDeps of

116119 Nothing -> Left (InclusionDependencyNameNotInUseError depName)

117− Just dep -> inclusionDependenciesAsRelation (M.singleton depName dep)

120+ Just dep ->

121+ inclusionDependenciesAsRelation (M.singleton depName dep) >>= renderRelExprsInIncDeps

118122 pure $ case val of

119123 Left err -> DisplayErrorResult (T.pack (show err))

120124 Right rel -> DisplayRelationResult rel

@@ -164,7 +168,7 @@ interpretRODatabaseContextOp sessionId conn tutdstring = case parse roDatabaseCo

164168

165169showDataFrameP :: Parser RODatabaseContextOperator

166170showDataFrameP = do

167− reservedOp ":showdataframe"

171+ colonOp ":showdataframe"

168172 relExpr <- relExprP

169173 reservedOp "orderby"

170174 attrOrdersExpr <- attrOrdersExprP

@@ -191,3 +195,16 @@ attrOrderExprP = DF.AttributeOrderExpr <$> identifier <*> orderP

191195

192196orderP :: Parser DF.Order

193197orderP = try (reservedOp "ascending" >> pure DF.AscendingOrder) <|> try (reservedOp "descending" >> pure DF.DescendingOrder) <|> pure DF.AscendingOrder

198+

199+-- render RelationalExprAtoms as TutorialD

200+renderRelExprsInIncDeps :: Relation -> Either RelationalError Relation

201+renderRelExprsInIncDeps = relMogrify tupMapper attrs

202+ where

203+ tupMapper tup = pure $ mkRelationTupleFromMap (M.map mapper (tupleToMap tup))

204+ mapper (RelationalExprAtom expr) = TextAtom (T.pack (show (prettyRelationalExpr expr)))

205+ mapper atom = atom

206+ attrs = C.attributesFromList [Attribute "name" TextAtomType,

207+ Attribute "sub" TextAtomType,

208+ Attribute "super" TextAtomType

209+ ]

210+

src/bin/TutorialD/Interpreter/RelationalExpr.hs+77−44

@@ -1,6 +1,11 @@

1+{-# LANGUAGE CPP #-}

12module TutorialD.Interpreter.RelationalExpr where

23import Text.Megaparsec

4+#if MIN_VERSION_megaparsec(7,0,0)

5+import Control.Monad.Combinators.Expr

6+#else

37import Text.Megaparsec.Expr

8+#endif

49import ProjectM36.Base

510import TutorialD.Interpreter.Base

611import TutorialD.Interpreter.Types

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

1217

1318--used in projection

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

15−attributeListP =

20+attributeListP =

1621 (reservedOp "all but" >>

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

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

23+

1824 (reservedOp "all from" >>

1925 RelationalExprAttributeNames <$> relExprP) <|>

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

26+

27+ (reservedOp "union of" >>

28+ UnionAttributeNames <$> braces attributeListP <*> braces attributeListP) <|>

29+

30+ (reservedOp "intersection of" >>

31+ IntersectAttributeNames <$> braces attributeListP <*> braces attributeListP) <|>

32+

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

34+

2135

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

2337makeRelationP = do

2438 reserved "relation"

2539 attrExprs <- try (fmap Just makeAttributeExprsP) <|> pure Nothing

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

27− pure $ MakeRelationFromExprs attrExprs tupleExprs

41+ marker <- parseMarkerP

42+ pure $ MakeRelationFromExprs attrExprs (TupleExprs marker tupleExprs)

43+

2844

29−

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

3146--Either Text Int

3247adTypeConstructorP :: Parser TypeConstructor

3348adTypeConstructorP = do

34− tConsName <- capitalizedIdentifier

49+ tConsName <- typeConstructorNameP

3550 tConsArgs <- many typeConstructorP

3651 pure $ ADTypeConstructor tConsName tConsArgs

3752

@@ -41,25 +56,25 @@ tupleExprP = do

4156 attrAssocs <- braces (sepBy tupleAtomExprP comma)

4257 --detect duplicate attribute names

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

44− if not (null dupAttrNames) then

59+ if not (null dupAttrNames) then

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

4661 else

4762 pure (TupleExpr (M.fromList attrAssocs))

4863

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

5065tupleAtomExprP = do

51− attributeName <- identifier

66+ attributeName <- attributeNameP

5267 atomExpr <- atomExprP

5368 pure (attributeName, atomExpr)

54−

69+

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

5671projectP = Project <$> braces attributeListP

5772

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

5974renameClauseP = do

60− oldAttr <- identifier

75+ oldAttr <- attributeNameP

6176 reservedOp "as"

62− newAttr <- identifier

77+ newAttr <- attributeNameP

6378 pure (oldAttr, newAttr)

6479

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

@@ -68,7 +83,7 @@ renameP = do

6883 renameList <- braces (sepBy renameClauseP comma)

6984 case renameList of

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

71− renames ->

86+ renames ->

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

7388

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

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

7893groupClauseP = do

7994 attrs <- braces attributeListP

8095 reservedOp "as"

81− newAttrName <- identifier

96+ newAttrName <- attributeNameP

8297 pure (attrs, newAttrName)

8398

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

@@ -91,26 +106,30 @@ groupP = do

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

92107ungroupP = do

93108 reservedOp "ungroup"

94− Ungroup <$> identifier

109+ Ungroup <$> attributeNameP

95110

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

97112extendP = do

98113 reservedOp ":"

99− Extend <$> braces extendTupleExpressionP

100−

114+ extends <- braces (sepBy extendTupleExpressionP comma)

115+ case extends of

116+ [] -> pure (Restrict TruePredicate)

117+ extends' ->

118+ pure $ \expr -> foldl (flip Extend) expr extends'

119+

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

102121semijoinP = do

103122 reservedOp "semijoin" <|> reservedOp "matching"

104− pure (\exprA exprB ->

123+ pure (\exprA exprB ->

105124 Project (RelationalExprAttributeNames exprA) (Join exprA exprB))

106−

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

125+

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

108127antijoinP = do

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

110129 pure (\exprA exprB ->

111130 Difference exprA (

112131 Project (RelationalExprAttributeNames exprA) (Join exprA exprB)))

113−

132+

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

115134relOperators = [

116135 [Postfix projectP],

@@ -123,15 +142,23 @@ relOperators = [

123142 [InfixL antijoinP],

124143 [InfixL (reservedOp "union" >> return Union)],

125144 [InfixL (reservedOp "minus" >> return Difference)],

126− [InfixN (reservedOp "=" >> return Equals)],

145+ [InfixN (reservedOp "=" >> return Equals),

146+ InfixN (reservedOp "/=" >> return NotEquals)],

127147 [Postfix extendP]

128148 ]

129149

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

131151relExprP = try withMacroExprP <|> makeExprParser relTerm relOperators

132152

153+--allow for additional characters

154+attributeNameP :: Parser AttributeName

155+attributeNameP = uncapitalizedIdentifier

156+

157+relVarNameP :: Parser RelVarName

158+relVarNameP = uncapitalizedIdentifier

159+

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

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

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

135162

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

137164relTerm = parens relExprP

@@ -152,13 +179,13 @@ restrictionPredicateP = makeExprParser predicateTerm predicateOperators

152179 <|> relationalBooleanExprP

153180

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

155−relationalBooleanExprP =

182+relationalBooleanExprP =

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

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

158−

185+

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

160187restrictionAttributeEqualityP = do

161− attributeName <- identifier

188+ attributeName <- attributeNameP

162189 reservedOp "="

163190 AttributeEqualityPredicate attributeName <$> atomExprP

164191

@@ -175,7 +202,7 @@ extendTupleExpressionP = attributeExtendTupleExpressionP

175202

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

177204attributeExtendTupleExpressionP = do

178− newAttr <- identifier

205+ newAttr <- attributeNameP

179206 reservedOp ":="

180207 AttributeExtendTupleExpr newAttr <$> atomExprP

181208

@@ -187,33 +214,34 @@ consumeAtomExprP consume = try functionAtomExprP <|>

187214 try (parens (constructedAtomExprP True)) <|>

188215 constructedAtomExprP consume <|>

189216 attributeAtomExprP <|>

190− nakedAtomExprP <|>

217+ try nakedAtomExprP <|>

191218 relationalAtomExprP

219+

192220

193221attributeAtomExprP :: Parser (AtomExprBase a)

194222attributeAtomExprP = do

195223 _ <- string "@"

196− AttributeAtomExpr <$> identifier

224+ AttributeAtomExpr <$> attributeNameP

197225

198226nakedAtomExprP :: Parser (AtomExprBase a)

199227nakedAtomExprP = NakedAtomExpr <$> atomP

200228

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

202230constructedAtomExprP consume = do

203− dConsName <- capitalizedIdentifier

231+ dConsName <- dataConstructorNameP

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

205233 ConstructedAtomExpr dConsName dConsArgs <$> parseMarkerP

206−

234+

207235-- used only for primitive type parsing ?

208236atomP :: Parser Atom

209−atomP = stringAtomP <|>

210− doubleAtomP <|>

211− integerAtomP <|>

237+atomP = stringAtomP <|>

238+ try doubleAtomP <|>

239+ integerAtomP <|>

212240 boolAtomP

213−

241+

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

215−functionAtomExprP =

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

243+functionAtomExprP =

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

217245

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

219247relationalAtomExprP = RelationAtomExpr <$> relExprP

@@ -221,25 +249,29 @@ relationalAtomExprP = RelationAtomExpr <$> relExprP

221249stringAtomP :: Parser Atom

222250stringAtomP = TextAtom <$> quotedString

223251

224−doubleAtomP :: Parser Atom

225−doubleAtomP = DoubleAtom <$> try float

252+doubleAtomP :: Parser Atom

253+doubleAtomP = DoubleAtom <$> float

226254

227255integerAtomP :: Parser Atom

228256integerAtomP = IntegerAtom <$> integer

229257

230258boolAtomP :: Parser Atom

231259boolAtomP = do

232− val <- char 't' <|> char 'f'

233− return $ BoolAtom (val == 't')

234−

260+ v <- identifier

261+ if v == "t" || v == "f" then

262+ pure $ BoolAtom (v == "t")

263+ else

264+ fail "invalid boolAtom"

265+

266+

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

236268relationAtomExprP = RelationAtomExpr <$> makeRelationP

237269

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

239271withMacroExprP = do

240272 reservedOp "with"

241− macros <- parens (sepBy1 createMacroP comma)

242− With macros <$> relExprP

273+ views <- parens (sepBy1 createMacroP comma)

274+ With views <$> relExprP

243275

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

245277createMacroP = do

@@ -248,4 +280,5 @@ createMacroP = do

248280 expr <- relExprP

249281 marker <- parseMarkerP

250282 pure (WithNameExpr name marker, expr)

251−

283+

284+

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

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

4242 reserved "isorestrict"

4343 relVarIn <- qrelVarP

4444 relvarsOut <- isoRestrictOutRelVarsP

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

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

4646

4747isoRestrictOutRelVarsP :: Parser (RelVarName, RelVarName)

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

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

5555 reserved "isounion"

5656 relVarsIn <- isoUnionInRelVarsP

5757 relVarsOut <- qrelVarP

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

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

5959

6060isoRenameP :: Parser SchemaIsomorph

6161isoRenameP = do

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

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

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

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

77−

77+

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

@@ -2,8 +2,9 @@

22module TutorialD.Interpreter.TransactionGraphOperator where

33import TutorialD.Interpreter.Base

44import ProjectM36.TransactionGraph hiding (autoMergeToHead)

5−import ProjectM36.Client

5+import ProjectM36.Client as C

66import ProjectM36.Base

7+import ProjectM36.Relation (relationTrue)

78import Data.Functor

910data ConvenienceTransactionGraphOperator = AutoMergeToHead MergeStrategy HeadName

@@ -71,6 +72,9 @@ mergeTransactionsP = do

7172 reservedOp ":mergetrans"

7273 MergeTransactions <$> mergeTransactionStrategyP <*> identifier <*> identifier

7374

75+validateMerkleHashesP :: Parser ROTransactionGraphOperator

76+validateMerkleHashesP = reservedOp ":validatemerklehashes" $> ValidateMerkleHashes

77+

7478transactionGraphOpP :: Parser TransactionGraphOperator

7579transactionGraphOpP =

7680 jumpToHeadP

@@ -83,7 +87,7 @@ transactionGraphOpP =

8387 <|> mergeTransactionsP

8488

8589roTransactionGraphOpP :: Parser ROTransactionGraphOperator

86−roTransactionGraphOpP = showGraphP

90+roTransactionGraphOpP = showGraphP <|> validateMerkleHashesP

8791

8892

8993

@@ -101,6 +105,11 @@ interpretOps newUUID trans@(DisconnectedTransaction _ context) transGraph instri

101105

102106evalROGraphOp :: SessionId -> Connection -> ROTransactionGraphOperator -> IO (Either RelationalError Relation)

103107evalROGraphOp sessionId conn ShowGraph = transactionGraphAsRelation sessionId conn

108+evalROGraphOp sessionId conn ValidateMerkleHashes = do

109+ eVal <- C.validateMerkleHashes sessionId conn

110+ case eVal of

111+ Left err -> pure (Left err)

112+ Right _ -> pure (Right relationTrue)

104113

105114evalConvenienceGraphOp :: SessionId -> Connection -> ConvenienceTransactionGraphOperator -> IO (Either RelationalError ())

106−evalConvenienceGraphOp sessionId conn (AutoMergeToHead strat head') = autoMergeToHead sessionId conn strat head'

115+evalConvenienceGraphOp sessionId conn (AutoMergeToHead strat head') = autoMergeToHead sessionId conn strat head'

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

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

1010instance RelationalMarkerExpr () where

1111 parseMarkerP = pure ()

12−

12+

13+typeConstructorNameP :: Parser TypeConstructorName

14+typeConstructorNameP = capitalizedIdentifier

15+

16+dataConstructorNameP :: Parser DataConstructorName

17+dataConstructorNameP = capitalizedIdentifier

18+

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

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

1521typeConstructorDefP :: Parser TypeConstructorDef

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

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

1723

1824typeVarNamesP :: Parser [TypeVarName]

1925typeVarNamesP = many uncapitalizedIdentifier

2026

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

2228dataConstructorDefP :: Parser DataConstructorDef

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

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

2430

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

2632dataConstructorDefArgP :: Parser DataConstructorDefArg

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

4753 monoTypeConstructorP

4854

4955monoTypeConstructorP :: Parser TypeConstructor

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

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

5157 TypeVariable <$> uncapitalizedIdentifier

5258

5359

src/bin/TutorialD/Printer.hsnew file+165

@@ -0,0 +1,165 @@

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

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeApplications #-}

6+module TutorialD.Printer where

7+import ProjectM36.Base

8+import ProjectM36.Attribute as A hiding (null)

9+import Data.Text.Prettyprint.Doc

10+import qualified Data.Set as S hiding (fromList)

11+import qualified Data.Vector as V

12+import qualified Data.Map.Strict as M

13+import Data.Time.Calendar

14+import Data.Time.Clock.POSIX

15+import qualified Data.ByteString.Base64 as B64

16+import qualified Data.Text.Encoding as TE

17+

18+instance Pretty Atom where

19+ pretty (IntegerAtom x) = pretty x

20+ pretty (IntAtom x) = "int" <> parensList [pretty x]

21+ pretty (DoubleAtom x) = pretty x

22+ pretty (TextAtom x) = dquotes (pretty x)

23+ pretty (DayAtom x) = "fromGregorian" <> parensList [pretty a, pretty b, pretty c]

24+ where

25+ (a,b,c) = toGregorian x

26+ pretty (DateTimeAtom time) = "dateTimeFromEpochSeconds" <> parensList [pretty @Integer (round (utcTimeToPOSIXSeconds time))]

27+ pretty (ByteStringAtom bs) = "bytestring" <> parensList [dquotes (pretty (TE.decodeUtf8 (B64.encode bs)))]

28+ pretty (BoolAtom x) = if x then "t" else "f"

29+ pretty (RelationAtom x) = pretty x

30+ pretty (RelationalExprAtom re) = pretty re

31+ pretty (ConstructedAtom n _ as) = pretty n <+> prettyList as

32+

33+instance Pretty AtomExpr where

34+ pretty (AttributeAtomExpr attrName) = pretty attrName

35+ pretty (NakedAtomExpr atom) = pretty atom

36+ pretty (FunctionAtomExpr atomFuncName' atomExprs _) = pretty atomFuncName' <> prettyAtomExprsAsArguments atomExprs

37+ pretty (RelationAtomExpr relExpr) = pretty relExpr

38+ pretty (ConstructedAtomExpr dName [] _) = pretty dName

39+ pretty (ConstructedAtomExpr dName atomExprs _) = pretty dName <+> hsep (map prettyAtomExpr atomExprs)

40+

41+prettyAtomExpr :: AtomExpr -> Doc ann

42+prettyAtomExpr atomExpr =

43+ case atomExpr of

44+ AttributeAtomExpr attrName -> "@" <> pretty attrName

45+ ConstructedAtomExpr dConsName [] () -> pretty dConsName

46+ ConstructedAtomExpr dConsName atomExprs () -> parens (pretty dConsName <+> hsep (map prettyAtomExpr atomExprs))

47+ _ -> pretty atomExpr

48+

49+prettyAtomExprsAsArguments :: [AtomExpr] -> Doc ann

50+prettyAtomExprsAsArguments = align . parensList . map addAt

51+ where addAt (atomExpr :: AtomExpr) =

52+ case atomExpr of

53+ AttributeAtomExpr attrName -> "@" <> pretty attrName

54+ _ -> pretty atomExpr

55+

56+instance Pretty TupleExpr where

57+ pretty (TupleExpr map') = "tuple" <> bracesList (Prelude.map (\(attrName,atom)-> pretty attrName <+> pretty atom) (M.toList map'))

58+

59+instance Pretty RelationTuple where

60+ pretty (RelationTuple attrs atoms) = "tuple" <> bracesList (zipWith (\x y-> pretty x <+> pretty y) (V.toList (attributeNames attrs)) (V.toList atoms))

61+

62+instance Pretty Relation where

63+ pretty (Relation attrs tupSet) | attrs == mempty && null (asList tupSet) = "false"

64+ pretty (Relation attrs tupSet) | attrs == mempty && asList tupSet == [RelationTuple mempty mempty] = "true"

65+ pretty (Relation attrs tupSet) = "relation" <> prettyBracesList (A.toList attrs) <> prettyBracesList (asList tupSet)

66+

67+instance Pretty Attribute where

68+ pretty (Attribute n aTy) = pretty n <+> pretty (show aTy) -- workaround

69+

70+instance Pretty RelationalExpr where

71+ pretty (RelationVariable n _) = pretty n

72+ pretty (ExistingRelation r) = pretty r

73+ pretty (NotEquals a b) = pretty' a <+> "!=" <+> pretty' b

74+ pretty (Equals a b) = pretty' a <+> "==" <+> pretty' b

75+ pretty (Project ns r) = pretty' (ignoreProjects r) <> pretty ns

76+ pretty (Extend ext r) = collectExtends r <> pretty ext <> "}"

77+ pretty (MakeRelationFromExprs Nothing (TupleExprs () tupExprs)) = "relation" <> prettyBracesList tupExprs

78+ pretty (MakeRelationFromExprs (Just attrExprs) (TupleExprs () tupExprs)) = "relation" <> prettyBracesList attrExprs <> prettyBracesList tupExprs

79+ pretty (MakeStaticRelation attrs tupSet) = "relation" <> prettyBracesList (A.toList attrs) <> prettyBracesList (asList tupSet)

80+ pretty (Union a b) = parens $ pretty' a <+> "union" <+> pretty' b

81+ pretty (Join a b) = parens $ pretty' a <+> "join" <+> pretty' b

82+ pretty (Rename n1 n2 relExpr) = parens $ pretty relExpr <+> "rename" <+> braces (pretty n1 <+> "as" <+> pretty n2)

83+ pretty (Difference a b) = parens $ pretty' a <+> "minus" <+> pretty' b

84+ pretty (Group attrNames attrName relExpr) = parens $ pretty relExpr <+> "group" <+> parens (pretty attrNames <+> "as" <+> pretty attrName)

85+ pretty (Ungroup attrName relExpr) = parens $ pretty' relExpr <+> "ungroup" <+> pretty attrName

86+ pretty (Restrict resPreExpr relExpr) = parens $ pretty' relExpr <+> "where" <+> pretty resPreExpr

87+ pretty (With pairs a) = "with" <+> parensList (map (\(name,expr)-> pretty name <+> "as" <+> pretty expr) pairs) <+> pretty' a

88+

89+-- relvar:{a:=?}:{b:=?}:... in ADTs => relvar:{a:=?, b:=?, ...} in Doc ann

90+collectExtends :: RelationalExpr -> Doc ann

91+collectExtends (Extend ext r) = collectExtends r <> pretty ext <> ", "

92+collectExtends r = pretty r <> ":{"

93+

94+--relvar{a,b,c,...}{a,b,...}..{a} => relvar{a}

95+ignoreProjects :: RelationalExpr -> RelationalExpr

96+ignoreProjects (Project _ r) = ignoreProjects r

97+ignoreProjects r = r

98+

99+prettyRelationalExpr :: RelationalExpr -> Doc n

100+prettyRelationalExpr (RelationVariable n _) = pretty n

101+prettyRelationalExpr r = parens (pretty r)

102+

103+pretty' :: RelationalExpr -> Doc n

104+pretty' = prettyRelationalExpr

105+

106+instance Pretty AttributeNames where

107+ pretty (AttributeNames attrNames) = prettyBracesList (S.toList attrNames)

108+ pretty (InvertedAttributeNames attrNames) = braces $ "all but" <+> concatWith (surround ", ") (map pretty (S.toList attrNames))

109+ pretty (RelationalExprAttributeNames relExpr) = braces $ "all from" <+> pretty relExpr

110+ pretty (UnionAttributeNames aAttrNames bAttrNames) = braces ("union of" <+> pretty aAttrNames <+> pretty bAttrNames)

111+ pretty (IntersectAttributeNames aAttrNames bAttrNames) = braces ("intersection of" <+> pretty aAttrNames <+> pretty bAttrNames)

112+

113+instance Pretty AttributeExpr where

114+ pretty (NakedAttributeExpr attr) = pretty attr

115+ pretty (AttributeAndTypeNameExpr name typeCons _) = pretty name <+> pretty typeCons

116+

117+instance Pretty TypeConstructor where

118+ pretty (ADTypeConstructor tcName []) = pretty tcName

119+ pretty (ADTypeConstructor tcName tConsArgs) = pretty tcName <+> hsep (map pretty tConsArgs)

120+ pretty (PrimitiveTypeConstructor tcName atomType') = pretty tcName <+> pretty atomType'

121+ pretty (RelationAtomTypeConstructor attrExprs) = "relation" <> prettyBracesList attrExprs

122+ pretty (TypeVariable x) = pretty x

123+

124+instance Pretty AtomType where

125+ pretty IntAtomType = "Int"

126+ pretty IntegerAtomType = "Integer"

127+ pretty DoubleAtomType = "Double"

128+ pretty TextAtomType = "Text"

129+ pretty DayAtomType = "Day"

130+ pretty DateTimeAtomType = "DateTime"

131+ pretty ByteStringAtomType = "ByteString"

132+ pretty BoolAtomType = "Bool"

133+ pretty (RelationAtomType attrs) = "relation " <+> prettyBracesList (A.toList attrs)

134+ pretty (ConstructedAtomType tcName tvMap) = pretty tcName <+> hsep (map pretty (M.toList tvMap)) --order matters

135+ pretty RelationalExprAtomType = "RelationalExpr"

136+ pretty (TypeVariableType x) = pretty x

137+

138+instance Pretty ExtendTupleExpr where

139+ pretty (AttributeExtendTupleExpr attrName atomExpr) = pretty attrName <> ":=" <> pretty atomExpr

140+

141+

142+instance Pretty RestrictionPredicateExpr where

143+ pretty TruePredicate = "true"

144+ pretty (AndPredicate a b) = pretty a <+> "and" <+> pretty b

145+ pretty (OrPredicate a b) = pretty a <+> "or" <+> pretty b

146+ pretty (NotPredicate a) = "not" <+> pretty a

147+ pretty (RelationalExprPredicate relExpr) = pretty relExpr

148+ pretty (AtomExprPredicate atomExpr) = pretty atomExpr

149+ pretty (AttributeEqualityPredicate attrName atomExpr) = pretty attrName <> "=" <> pretty atomExpr

150+

151+instance Pretty WithNameExpr where

152+ pretty (WithNameExpr name _) = pretty name

153+

154+bracesList :: [Doc ann] -> Doc ann

155+bracesList = group . encloseSep (flatAlt "{ " "{") (flatAlt " }" "}") ", "

156+

157+prettyBracesList :: Pretty a => [a] -> Doc ann

158+prettyBracesList = align . bracesList . map pretty

159+

160+parensList :: [Doc ann] -> Doc ann

161+parensList = group . encloseSep (flatAlt "( " "(") (flatAlt " )" ")") ", "

162+

163+prettyParensList :: Pretty a => [a] -> Doc ann

164+prettyParensList = align . parensList . map pretty

165+

src/bin/TutorialD/tutd.hs+15−19

@@ -5,9 +5,11 @@ import ProjectM36.Client

55import ProjectM36.Server.ParseArgs

66import ProjectM36.Server

77import System.IO

8+import GHC.IO.Encoding

89import Options.Applicative

910import System.Exit

10−#if __GLASGOW_HASKELL__ <= 802

11+import Control.Monad

12+#if __GLASGOW_HASKELL__ < 804

1113import Data.Monoid

1214#endif

1315import Data.Maybe

@@ -20,7 +22,7 @@ import qualified Data.Text as T

2022

2123parseArgs :: Parser InterpreterConfig

2224parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseTutDExec <*> many parseGhcPkgPath <*> parseCheckFS <|>

23− RemoteInterpreterConfig <$> parseNodeId <*> parseDatabaseName <*> parseHeadName <*> parseTutDExec <*> parseCheckFS

25+ RemoteInterpreterConfig <$> parseHostname "127.0.0.1" <*> parsePort defaultServerPort <*> parseDatabaseName <*> parseHeadName <*> parseTutDExec <*> parseCheckFS

2426

2527parseHeadName :: Parser HeadName

2628parseHeadName = option auto (long "head" <>

@@ -29,19 +31,6 @@ parseHeadName = option auto (long "head" <>

2931 value "master"

3032 )

3133

32−parseNodeId :: Parser NodeId

33−parseNodeId = createNodeId <$>

34− strOption (long "host" <>

35− short 'h' <>

36− help "Remote host name" <>

37− metavar "HOSTNAME" <>

38− value "127.0.0.1") <*>

39− option auto (long "port" <>

40− metavar "PORT NUMBER" <>

41− short 'p' <>

42− help "Remote port" <>

43− value defaultServerPort)

44−

4534--just execute some tutd and exit

4635parseTutDExec :: Parser (Maybe TutorialDExec)

4736parseTutDExec = optional $ strOption (long "exec-tutd" <>

@@ -55,19 +44,19 @@ opts = info (parseArgs <**> helpOption) idm

5544

5645connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo

5746connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths _) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths

58−connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _ _ _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId outputNotificationCallback

47+connectionInfoForConfig (RemoteInterpreterConfig remoteHost remotePort remoteDBName _ _ _) = RemoteConnectionInfo remoteDBName remoteHost (show remotePort) outputNotificationCallback

5948

6049headNameForConfig :: InterpreterConfig -> HeadName

6150headNameForConfig (LocalInterpreterConfig _ headn _ _ _) = headn

62−headNameForConfig (RemoteInterpreterConfig _ _ headn _ _) = headn

51+headNameForConfig (RemoteInterpreterConfig _ _ _ headn _ _) = headn

6352

6453execTutDForConfig :: InterpreterConfig -> Maybe String

6554execTutDForConfig (LocalInterpreterConfig _ _ t _ _) = t

66−execTutDForConfig (RemoteInterpreterConfig _ _ _ t _) = t

55+execTutDForConfig (RemoteInterpreterConfig _ _ _ _ t _) = t

6756

6857checkFSForConfig :: InterpreterConfig -> Bool

6958checkFSForConfig (LocalInterpreterConfig _ _ _ _ c) = c

70−checkFSForConfig (RemoteInterpreterConfig _ _ _ _ c) = c

59+checkFSForConfig (RemoteInterpreterConfig _ _ _ _ _ c) = c

7160

7261persistenceStrategyForConfig :: InterpreterConfig -> Maybe PersistenceStrategy

7362persistenceStrategyForConfig (LocalInterpreterConfig strat _ _ _ _) = Just strat

@@ -86,8 +75,15 @@ printWelcome = do

8675 putStrLn "A full tutorial is available at:"

8776 putStrLn "https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown"

8877

78+-- | If the locale is set to ASCII, upgrade it to UTF-8 because tutd outputs UTF-8-encoded attributes. This is especially important in light docker images where the locale data may be missing.

79+setLocaleIfNecessary :: IO ()

80+setLocaleIfNecessary = do

81+ l <- getLocaleEncoding

82+ when (textEncodingName l == "ASCII") (setLocaleEncoding utf8)

83+

8984main :: IO ()

9085main = do

86+ setLocaleIfNecessary

9187 interpreterConfig <- execParser opts

9288 let connInfo = connectionInfoForConfig interpreterConfig

9389 fscheck <- checkFSType (checkFSForConfig interpreterConfig) (fromMaybe NoPersistence (persistenceStrategyForConfig interpreterConfig))

src/bin/benchmark/Handles.hs+25−14

@@ -6,13 +6,15 @@ import Options.Applicative

66import TutorialD.Interpreter

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

88import qualified Data.Text as T

9+#if __GLASGOW_HASKELL__ < 804

910import Data.Monoid

11+#endif

1012import Control.Monad

1113

1214data HandlesArgs = HandlesArgs {

1315 openCloseCount :: Int,

1416 transactionCount :: Int,

15− dbdir :: FilePath,

17+ dbdir :: FilePath,

1618 tutdSetup :: String,

1719 tutdIterate :: String

1820 }

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

3840main :: IO ()

3941main = do

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

41− replicateM_ (openCloseCount args) (runOpenClose

43+ replicateM_ (openCloseCount args) (runOpenClose

4244 (T.pack (tutdSetup args))

4345 (T.pack (tutdIterate args))

44− (transactionCount args)

46+ (transactionCount args)

4547 (dbdir args))

46−

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

48+

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

4850runOpenClose tutdSetup' tutdIterate' tCount dbdir' = do

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

5052 eConn <- connectProjectM36 connInfo

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

5456 eSess <- createSessionAtHead conn "master"

5557 case eSess of

5658 Left err -> error (show err)

57− Right session ->

59+ Right session ->

5860 --database setup

5961 case parseTutorialD tutdSetup' of

6062 Left err -> error (show err)

@@ -62,14 +64,19 @@ runOpenClose tutdSetup' tutdIterate' tCount dbdir' = do

6264 res <- evalTutorialD session conn UnsafeEvaluation parsed

6365 case res of

6466 DisplayErrorResult err -> error (T.unpack err)

65− DisplayParseErrorResult _ err -> error (parseErrorPretty err)

66− _ -> do

67+ DisplayParseErrorResult _ err ->

68+#if MIN_VERSION_megaparsec(7,0,0)

69+ error (errorBundlePretty err)

70+#else

71+ error (parseErrorPretty err)

72+#endif

73+ _ -> do

6774 replicateM_ tCount (runTransaction tutdIterate' session conn)

6875 close conn

6976 printFdCount

70−

77+

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

72−runTransaction tutdIterate' sess conn =

79+runTransaction tutdIterate' sess conn =

7380 --run tutd on every iteration

7481 case parseTutorialD tutdIterate' of

7582 Left err -> error (show err)

@@ -77,10 +84,14 @@ runTransaction tutdIterate' sess conn =

7784 res <- evalTutorialD sess conn UnsafeEvaluation parsed

7885 case res of

7986 DisplayErrorResult err -> error (T.unpack err)

80− DisplayParseErrorResult _ err -> error (parseErrorPretty err)

81− _ -> do

82− eErr <- commit sess conn

87+ DisplayParseErrorResult _ err ->

88+#if MIN_VERSION_megaparsec(7,0,0)

89+ error (errorBundlePretty err)

90+#else

91+ error (parseErrorPretty err)

92+#endif

93+ _ -> do

94+ eErr <- commit sess conn

8395 case eErr of

8496 Left err -> error (show err)

8597 Right _ -> printFdCount

86−

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

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

1−{-# LANGUAGE FlexibleInstances #-}

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

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

33import ProjectM36.Base

44import ProjectM36.Relation

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

99import qualified Data.Text as T

1010--import ProjectM36.Relation.Show.CSV

1111import ProjectM36.Relation.Show.HTML

12−import TutorialD.Interpreter.DatabaseContextExpr (interpretDatabaseContextExpr)

1312import ProjectM36.RelationalExpression

1413import ProjectM36.TransactionGraph

1514--import qualified Data.HashSet as HS

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

1817--import qualified Data.Hashable as Hash

1918import qualified Data.Vector as V

2019import Options.Applicative

21−import qualified Data.Map as M

2220import qualified Data.Text.IO as TIO

2321import System.IO

24−import Control.Monad.State

2522import Control.DeepSeq

2623import Data.Text hiding (map)

27−import Data.Monoid

2824import Data.Time.Clock

29−import Data.UUID

3025import Data.UUID.V4

26+#if __GLASGOW_HASKELL__ < 804

27+import Data.Monoid

28+#endif

29+

3130

3231{-

3332dumpcsv :: Relation -> IO ()

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

7675 case eNewState of

7776 Right newState -> do

7877 let ctx = dbc_context newState

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

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

79+ env' = RelationalExprEnv ctx graph Nothing

80+ TIO.putStrLn $ relationAsHTML x

8081 Left err -> hPrint stderr err

8182

8283{-

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

@@ -9,6 +9,7 @@ import ProjectM36.AtomType

99import ProjectM36.Attribute (atomType)

1010import ProjectM36.DataConstructorDef as DCD

1111import ProjectM36.DataTypes.Interval

12+import ProjectM36.Relation

1213import qualified Data.Vector as V

1314import Data.Text (Text)

1415import Test.QuickCheck

@@ -48,6 +49,10 @@ arbitrary' ByteStringAtomType =

4849

4950arbitrary' BoolAtomType =

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

52+

53+arbitrary' RelationalExprAtomType =

54+ pure (Right (RelationalExprAtom (ExistingRelation relationTrue))) -- don't bother with arbitrary relational expressions

55+

5156arbitrary' constructedAtomType@(ConstructedAtomType tcName tvMap)

5257 --special-casing for Interval type

5358 | isIntervalAtomType constructedAtomType = createArbitraryInterval (intervalSubType constructedAtomType)

@@ -79,7 +84,7 @@ maybeToRight y Nothing = Left y

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

8085arbitraryRelationTuple attris = do

8186 tcMap <- ask

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

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

8388 case sequence listOfMaybeAType of

8489 Left err -> pure $ Left err

8590 Right listOfAttr -> do

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

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

33import ProjectM36.Error

44import ProjectM36.DataTypes.Interval

55import qualified Data.Text as T

6−#if __GLASGOW_HASKELL__ <= 802

6+#if __GLASGOW_HASKELL__ < 804

77import Data.Monoid

88#endif

@@ -20,6 +20,7 @@ atomToText (DayAtom i) = (T.pack . show) i

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

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

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

23+atomToText (RelationalExprAtom re) = (T.pack . show) re

2324

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

2526atomToText (ConstructedAtom dConsName typ atoms)

src/lib/ProjectM36/AtomFunction.hs+19−2

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

1+{-# LANGUAGE CPP #-}

12module ProjectM36.AtomFunction where

23import ProjectM36.Base

4+import ProjectM36.Serialise.Base ()

35import ProjectM36.Error

46import ProjectM36.Relation

57import ProjectM36.AtomType

@@ -8,7 +10,8 @@ import ProjectM36.ScriptSession

810import qualified ProjectM36.Attribute as A

911import qualified Data.HashSet as HS

1012import qualified Data.Text as T

11−

13+import qualified Data.ByteString.Lazy as BL

14+import Codec.Winery

1215

1316foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

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

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

7275 retType]])

7376

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

78+#ifdef PM36_HASKELL_SCRIPTING

7579loadAtomFunctions = loadFunction

80+#else

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

82+#endif

7683

7784atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation

7885atomFunctionsAsRelation funcs = mkRelationFromList attrs tups

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

8188 Attribute "arguments" TextAtomType]

8289 atomFuncToTuple aFunc = [TextAtom (atomFuncName aFunc),

8390 TextAtom (atomFuncTypeToText aFunc)]

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

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

92+

93+--for calculating the merkle hash

94+hashBytes :: AtomFunction -> BL.ByteString

95+hashBytes func = BL.fromChunks [serialise (atomFuncName func),

96+ serialise (atomFuncType func),

97+ bodyBin

98+ ]

99+ where

100+ bodyBin = case atomFuncBody func of

101+ AtomFunctionBody mScript _ -> serialise mScript

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

@@ -1,6 +1,5 @@

11{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}

22module ProjectM36.AtomFunctionError where

3−import Data.Binary

43import GHC.Generics

54import Control.DeepSeq

65import Data.Text

@@ -14,5 +13,5 @@ data AtomFunctionError = AtomFunctionUserError String |

1413 AtomTypeDoesNotSupportOrderingError Text |

1514 AtomTypeDoesNotSupportIntervalError Text |

1615 AtomFunctionBytesDecodingError String

17− deriving(Generic, Eq, Show, Binary, NFData)

16+ deriving(Generic, Eq, Show, NFData)

1817

src/lib/ProjectM36/AtomType.hs+86−14

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

139139

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

141141-- check that the data constructor names are unique

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

143−validateTypeConstructorDef tConsDef dConsList = execWriter $ do

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

143+validateTypeConstructorDef tConsDef dConsList tConsMap = do

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

145− mapM_ tell [map DataConstructorNameInUseError duplicateDConsNames]

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

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

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

148148 varsDiff = S.difference leftSideVars rightSideVars

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

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

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

151+

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

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

154+validateDataConstructorDef (DataConstructorDef dConsName dConsDefArgs) tConsDef tConsMap =

155+ case findDataConstructor dConsName tConsMap of

156+ Just _ -> Left (DataConstructorNameInUseError dConsName)

157+ Nothing ->

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

159+

160+

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

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

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

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

165+ Nothing ->

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

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

168+ let existingCount = length tConsArgs

169+ newCount = length (TC.arguments tCons)

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

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

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

150173

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

152175atomTypeForTypeConstructor = atomTypeForTypeConstructorValidate False

@@ -188,7 +211,7 @@ isValidAtomTypeForTypeConstructor (ConstructedAtomType tConsName _) (ADTypeConst

188211

189212isValidAtomTypeForTypeConstructor (RelationAtomType attrs) (RelationAtomTypeConstructor attrExprs) tConsMap = do

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

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

214+ mapM_ (uncurry resolveAtomType) (zip (A.atomTypesList attrs) evaldAtomTypes)

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

193216

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

@@ -198,10 +221,18 @@ findTypeConstructor name = foldr tConsFolder Nothing

198221 Just (tCons, dConsList)

199222 else

200223 accum

201−

224+

225+resolveAttributes :: Attribute -> Attribute -> Either RelationalError Attribute

226+resolveAttributes attrA attrB =

227+ if A.attributeName attrA /= A.attributeName attrB then

228+ Left $ AttributeNamesMismatchError (S.fromList (map A.attributeName [attrA, attrB]))

229+ else

230+ Attribute (A.attributeName attrA) <$> resolveAtomType (A.atomType attrA) (A.atomType attrB)

231+

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

202233resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType

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

204− ConstructedAtomType tConsName <$> resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

235+ ConstructedAtomType tConsName <$> resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

205236resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then

206237 Right typeFromRelation

207238 else

@@ -229,12 +260,16 @@ resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do

229260 let resolveTypePair resKey resType =

230261 -- if the key is missing in the unresolved type map, then fill it in with the value from the resolved map

231262 case M.lookup resKey unresolvedTypeMap of

232− Just unresType -> case unresType of

263+ Just unresType -> case unresType of

233264 --do we need to recurse for RelationAtomType?

234265 subType@(ConstructedAtomType _ _) -> do

235266 resSubType <- resolveAtomType resType subType

236267 pure (resKey, resSubType)

237− _ -> pure (resKey, resType)

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

269+ typ -> if typ == resType then

270+ pure (resKey, resType)

271+ else

272+ Left $ AtomTypeMismatchError typ resType

238273 Nothing ->

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

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

@@ -260,7 +295,7 @@ resolveTypeInAtom _ atom _ = Right atom

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

261296resolveTypesInTuple :: Attributes -> TypeConstructorMapping -> RelationTuple -> Either RelationalError RelationTuple

262297resolveTypesInTuple resolvedAttrs tConss (RelationTuple _ tupAtoms) = do

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

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

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

265300

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

@@ -279,10 +314,19 @@ validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss =

279314 _ -> Right ()

280315validateAtomType (RelationAtomType attrs) tConss =

281316 mapM_ (\attr ->

282− validateAtomType (A.atomType attr) tConss) (V.toList attrs)

317+ validateAtomType (A.atomType attr) tConss) (attributesVec attrs)

283318validateAtomType (TypeVariableType x) _ = Left (TypeConstructorTypeVarMissing x)

284319validateAtomType _ _ = pure ()

285320

321+validateAttributes :: TypeConstructorMapping -> Attributes -> Either RelationalError ()

322+validateAttributes tConss attrs =

323+ if not (null errs) then

324+ Left (someErrors errs)

325+ else

326+ pure ()

327+ where

328+ errs = lefts $ map (`validateAtomType` tConss) (A.atomTypesList attrs)

329+

286330--ensure that all type vars are fully resolved

287331validateTypeVarMap :: TypeVarMap -> TypeConstructorMapping -> Either RelationalError ()

288332validateTypeVarMap tvMap tConss = mapM_ (`validateAtomType` tConss) $ M.elems tvMap

@@ -314,7 +358,7 @@ atomTypeVerify x@(RelationAtomType attrs1) y@(RelationAtomType attrs2) = do

314358 if notElem "_" [name1, name2] && name1 /= name2 then

315359 Left $ AtomTypeMismatchError x y

316360 else

317− atomTypeVerify (A.atomType attr1) (A.atomType attr2)) $ V.toList (V.zip attrs1 attrs2)

361+ atomTypeVerify (A.atomType attr1) (A.atomType attr2)) $ V.toList (V.zip (attributesVec attrs1) (attributesVec attrs2))

318362 return x

319363atomTypeVerify x y = if x == y then

320364 Right x

@@ -323,10 +367,15 @@ atomTypeVerify x y = if x == y then

323367

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

325369typeVarMapsVerify :: TypeVarMap -> TypeVarMap -> Bool

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

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

371+ where

372+ zipped = zipWith

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

374+ (M.toAscList a)

375+ (M.toAscList b)

327376

328377prettyAtomType :: AtomType -> T.Text

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

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

330379prettyAtomType (ConstructedAtomType tConsName typeVarMap) = tConsName `T.append` T.concat (map showTypeVars (M.toList typeVarMap))

331380 where

332381 showTypeVars (_, TypeVariableType x) = " " <> x

@@ -382,3 +431,26 @@ resolvedAtomTypeForDataConstructorDefArg _ tvMap (DataConstructorDefTypeVarNameA

382431 Nothing -> Left (DataConstructorUsesUndeclaredTypeVariable tvName)

383432 Just typ -> Right typ

384433

434+isResolvedType :: AtomType -> Bool

435+isResolvedType typ =

436+ case typ of

437+ IntAtomType -> True

438+ IntegerAtomType -> True

439+ DoubleAtomType -> True

440+ TextAtomType -> True

441+ DayAtomType -> True

442+ DateTimeAtomType -> True

443+ ByteStringAtomType -> True

444+ BoolAtomType -> True

445+ RelationalExprAtomType -> True

446+ RelationAtomType attrs -> isResolvedAttributes attrs

447+ ConstructedAtomType _ tvMap -> all isResolvedType (M.elems tvMap)

448+ TypeVariableType _ -> False

449+

450+isResolvedAttributes :: Attributes -> Bool

451+isResolvedAttributes attrs = all isResolvedAttribute (V.toList (attributesVec attrs))

452+

453+isResolvedAttribute :: Attribute -> Bool

454+isResolvedAttribute = isResolvedType . A.atomType

455+

456+--given two AtomTypes x,y

src/lib/ProjectM36/Atomable.hs+33−49

@@ -13,29 +13,16 @@ import qualified Data.Map as M

1313import qualified Data.Text as T

1414import qualified Data.Vector as V

1515import Control.DeepSeq (NFData)

16−import Data.Binary

1716import Control.Applicative

1817import Data.Time.Calendar

1918import Data.ByteString (ByteString)

2019import Data.Time.Clock

2120import Data.Proxy

2221import qualified Data.List.NonEmpty as NE

22+import Codec.Winery

2323

24−--also add haskell scripting atomable support

25−--rename this module to Atomable along with test

26−

27−{-

28−data Test1T = Test1C Int

29− deriving (Generic, Show, Eq, Binary, NFData, Atomable)

30−

31−data Test2T = Test2C Int Int

32− deriving (Generic, Show, Eq, Binary, NFData, Atomable)

33−

34−data Test3T = Test3Ca | Test3Cb

35− deriving (Generic, Show, Eq, Binary, NFData, Atomable)

36−-}

3724-- | All database values ("atoms") adhere to the 'Atomable' typeclass. This class is derivable allowing new datatypes to be easily marshaling between Haskell values and database values.

38−class (Eq a, NFData a, Binary a, Show a) => Atomable a where

25+class (Eq a, NFData a, Serialise a, Show a) => Atomable a where

3926 toAtom :: a -> Atom

4027 default toAtom :: (Generic a, AtomableG (Rep a)) => a -> Atom

4128 toAtom v = toAtomG (from v) (toAtomTypeG (from v))

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

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

5744 toAddTypeExpr :: proxy a -> DatabaseContextExpr

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

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

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

6047

6148instance Atomable Integer where

6249 toAtom = IntegerAtom

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

148135--convert to ADT list

149136instance Atomable a => Atomable [a] where

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

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

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

152139

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

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

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

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

156143

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

@@ -165,10 +152,6 @@ instance Atomable a => Atomable (NE.NonEmpty a) where

165152 toAtomType _ = ConstructedAtomType "NonEmptyList" (M.singleton "a" (toAtomType (Proxy :: Proxy a)))

166153 toAddTypeExpr _ = NoOperation

167154

168−#if !MIN_VERSION_binary(0,8,4)

169−instance Binary a => Binary (NE.NonEmpty a)

170−#endif

171−

172155-- Generics

173156class AtomableG g where

174157 --type AtomTG g

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

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

185168 toAtomG (M1 v) = toAtomG v

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

187− toAtomsG = undefined

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

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

189172 where

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

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

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

192175 where

193176 tcDef = ADTypeConstructorDef tcName []

194177 dataConstructors = getConstructorsG v

195178 toAddTypeExprG _ _ = NoOperation

196− getConstructorsG (M1 v) = getConstructorsG v

197− getConstructorArgsG = undefined

179+ getConstructorsG ~(M1 v) = getConstructorsG v

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

198181

199182--constructor metadata

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

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

209192 Nothing

210193 where

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

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

213− toAtomsG = undefined

214− toAtomTypeG = undefined

215− toAddTypeExprG = undefined

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

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

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

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

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

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

217200 where

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

219202 dArgs = getConstructorArgsG v

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

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

226209 toAtomsG (M1 v) = toAtomsG v

227210 toAtomTypeG (M1 v) = toAtomTypeG v

228− toAddTypeExprG _ _ = undefined

229− getConstructorsG = undefined

230− getConstructorArgsG (M1 v) = getConstructorArgsG v

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

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

213+ getConstructorArgsG ~(M1 v) = getConstructorArgsG v

231214

232215-- field data metadata

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

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

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

238221 toAtomsG (K1 v) = [toAtom v]

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

240− toAddTypeExprG _ _ = undefined

241− getConstructorsG = undefined

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

223+ toAddTypeExprG = error "invalid toAddTypeExprG in K1"

224+ getConstructorsG = error "invalid getConstructorsG in K1"

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

243226 where

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

245228

@@ -252,8 +235,9 @@ typeToTypeConstructor x@DayAtomType = PrimitiveTypeConstructor "Day" x

252235typeToTypeConstructor x@DateTimeAtomType = PrimitiveTypeConstructor "DateTime" x

253236typeToTypeConstructor x@ByteStringAtomType = PrimitiveTypeConstructor "ByteString" x

254237typeToTypeConstructor x@BoolAtomType = PrimitiveTypeConstructor "Bool" x

238+typeToTypeConstructor x@RelationalExprAtomType = PrimitiveTypeConstructor "RelationalExpr" x

255239typeToTypeConstructor (RelationAtomType attrs)

256− = RelationAtomTypeConstructor $ map attrToAttrExpr $ V.toList attrs

240+ = RelationAtomTypeConstructor $ map attrToAttrExpr $ V.toList (attributesVec attrs)

257241 where

258242 attrToAttrExpr (Attribute n t) = AttributeAndTypeNameExpr n (typeToTypeConstructor t) ()

259243typeToTypeConstructor (ConstructedAtomType tcName tvMap)

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

261245typeToTypeConstructor (TypeVariableType tvName) = TypeVariable tvName

262246

263247instance AtomableG U1 where

264− toAtomG = undefined

248+ toAtomG = error "invalid toAtomG in U1"

265249 fromAtomG _ _ = pure U1

266250 toAtomsG _ = []

267− toAtomTypeG = undefined

268− toAddTypeExprG = undefined

269− getConstructorsG = undefined

251+ toAtomTypeG = error "invalid toAtomTypeG in U1"

252+ toAddTypeExprG = error "invalid toAddTypeExprG in U1"

253+ getConstructorsG = error "invalid getConstructorsG in U1"

270254 getConstructorArgsG _ = []

271255

272256-- product types

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

276260 where splitargs1 = take splitpoint args

277261 splitargs2 = drop splitpoint args

278262 splitpoint = length args `div` 2

279− toAtomTypeG = undefined

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

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

281− toAddTypeExprG _ _ = undefined

282− getConstructorsG = undefined

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

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

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

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

284268

285269-- sum types

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

287271 toAtomG (L1 x) = toAtomG x

288272 toAtomG (R1 x) = toAtomG x

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

290− toAtomTypeG = undefined

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

291275 toAtomsG (L1 x) = toAtomsG x

292276 toAtomsG (R1 x) = toAtomsG x

293− toAddTypeExprG _ _ = undefined

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

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

295− getConstructorArgsG = undefined

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

296280

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

298282{-

src/lib/ProjectM36/Attribute.hs+148−29

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

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

12module ProjectM36.Attribute where

23import ProjectM36.Base

34import ProjectM36.Error

@@ -10,16 +11,54 @@ import qualified Data.Map as M

1011import Data.Either

1112

1213arity :: Attributes -> Int

13−arity = V.length

14+arity a = V.length (attributesVec a)

15+

16+instance Semigroup Attributes where

17+ attrsA <> attrsB =

18+ case joinAttributes attrsA attrsB of

19+ Left err -> error (show err)

20+ Right attrs' -> attrs'

21+

22+instance Monoid Attributes where

23+ mempty = Attributes {

24+ attributesVec = mempty

25+ --,attributeSet = mempty

26+ }

1427

1528emptyAttributes :: Attributes

16−emptyAttributes = V.empty

29+emptyAttributes = mempty

1730

1831null :: Attributes -> Bool

19−null = V.null

32+null a = V.null (attributesVec a)

33+

34+singleton :: Attribute -> Attributes

35+singleton attr = Attributes {

36+ attributesVec = V.singleton attr

37+ --,attributesSet = HS.singleton attr

38+ }

39+

40+toList :: Attributes -> [Attribute]

41+toList attrs = V.toList (attributesVec attrs)

2042

2143attributesFromList :: [Attribute] -> Attributes

22−attributesFromList = V.fromList -- . L.nub --too expensive

44+attributesFromList attrsL = Attributes {

45+ attributesVec = vec

46+ --,attributesSet = hset

47+ }

48+ where

49+ vec = if length attrsL == HS.size hset then

50+ --fast path- no duplicates

51+ V.fromList attrsL

52+ else

53+ --duplicate detected, uniqueify while maintaining original ordering

54+ V.fromList uniquedL

55+ hset = HS.fromList attrsL

56+ uniquedL = fst $ foldr (\attr acc@(l,s) ->

57+ if HS.member attr s then

58+ acc

59+ else

60+ (l ++ [attr], HS.insert attr s))

61+ ([],mempty) attrsL

2362

2463attributeName :: Attribute -> AttributeName

2564attributeName (Attribute name _) = name

@@ -28,17 +67,16 @@ atomType :: Attribute -> AtomType

2867atomType (Attribute _ atype) = atype

2968

3069atomTypes :: Attributes -> V.Vector AtomType

31−atomTypes = V.map atomType

70+atomTypes attrs = V.map atomType (attributesVec attrs)

3271

3372atomTypesList :: Attributes -> [AtomType]

3473atomTypesList = V.toList . atomTypes

3574

36−--hm- no error-checking here

3775addAttribute :: Attribute -> Attributes -> Attributes

38−addAttribute attr attrs = attrs `V.snoc` attr

76+addAttribute attr attrs = attrs <> singleton attr

3977

4078--if some attribute names overlap but the types do not, then spit back an error

41−joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes

79+{-joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes

4280joinAttributes attrs1 attrs2 | V.length uniqueOverlappingAttributes /= V.length overlappingAttributes = Left (TupleAttributeTypeMismatchError overlappingAttributes)

4381 | V.length overlappingAttrsDifferentTypes > 0 = Left (TupleAttributeTypeMismatchError overlappingAttrsDifferentTypes)

4482 | otherwise = Right $ vectorUniqueify (attrs1 V.++ attrs2)

@@ -47,20 +85,52 @@ joinAttributes attrs1 attrs2 | V.length uniqueOverlappingAttributes /= V.length

4785 attrNames2 = V.map attributeName attrs2

4886 uniqueOverlappingAttributes = vectorUniqueify overlappingAttributes

4987 overlappingAttributes = V.filter (`V.elem` attrs2) attrs1

88+-}

89+joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes

90+joinAttributes attrs1 attrs2

91+ | S.size overlappingNames == 0 = -- fast path, no overlapping names

92+ pure (concated id)

93+ | attributesForNames overlappingNames attrs1 == attributesForNames overlappingNames attrs2 = -- that atomtypes match

94+ pure (concated vectorUniqueify)

95+ | otherwise =

96+ --special handling to validate that overlapping names have the same atom types

97+ Left (TupleAttributeTypeMismatchError (attributesForNames overlappingNames attrs1))

98+ where

99+ nameSet1 = attributeNameSet attrs1

100+ nameSet2 = attributeNameSet attrs2

101+ overlappingNames = S.intersection nameSet1 nameSet2

102+ concated f = Attributes {

103+ attributesVec = f (attributesVec attrs1 <> attributesVec attrs2)

104+ --,attributesSet = attributesSet attrs1 <> attributesSet attrs2

105+ }

50106

51107addAttributes :: Attributes -> Attributes -> Attributes

52−addAttributes = (V.++)

108+addAttributes = (<>)

109+

110+member :: Attribute -> Attributes -> Bool

111+member attr attrs = HS.member attr (attributesSet attrs)

53112

54113deleteAttributeName :: AttributeName -> Attributes -> Attributes

55−deleteAttributeName attrName = V.filter (\attr -> attributeName attr /= attrName)

114+deleteAttributeName attrName = deleteAttributeNames (S.singleton attrName)

115+

116+deleteAttributeNames :: S.Set AttributeName -> Attributes -> Attributes

117+deleteAttributeNames attrNames attrs = Attributes {

118+ attributesVec = vec

119+ }

120+ where

121+ vec = V.filter attrFilter (attributesVec attrs)

122+ attrFilter attr = S.notMember (attributeName attr) attrNames

56123

57124renameAttribute :: AttributeName -> Attribute -> Attribute

58125renameAttribute newAttrName (Attribute _ typeo) = Attribute newAttrName typeo

59126

60127renameAttributes :: AttributeName -> AttributeName -> Attributes -> Attributes

61−renameAttributes oldAttrName newAttrName = V.map renamer

128+renameAttributes oldAttrName newAttrName attrs = Attributes {

129+ attributesVec = vec

130+ }

62131 where

63− renamer attr = if attributeName attr == oldAttrName then

132+ vec = V.map renamer (attributesVec attrs)

133+ renamer attr = if attributeName attr == oldAttrName then

64134 renameAttribute newAttrName attr

65135 else

66136 attr

@@ -71,7 +141,7 @@ atomTypeForAttributeName attrName attrs = do

71141 return atype

72142

73143attributeForName :: AttributeName -> Attributes -> Either RelationalError Attribute

74−attributeForName attrName attrs = case V.find (\attr -> attributeName attr == attrName) attrs of

144+attributeForName attrName attrs = case V.find (\attr -> attributeName attr == attrName) (attributesVec attrs) of

75145 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))

76146 Just attr -> Right attr

77147

@@ -89,15 +159,18 @@ projectionAttributesForNames names attrsIn =

89159 missingNames = attributeNamesNotContained names (S.fromList (V.toList (attributeNames attrsIn)))

90160

91161attributesForNames :: S.Set AttributeName -> Attributes -> Attributes

92−attributesForNames attrNameSet = V.filter filt

162+attributesForNames attrNameSet attrs = Attributes {

163+ attributesVec = vec

164+ }

93165 where

166+ vec = V.filter filt (attributesVec attrs)

94167 filt attr = S.member (attributeName attr) attrNameSet

95168

96169attributeNameSet :: Attributes -> S.Set AttributeName

97−attributeNameSet attrVec = S.fromList $ V.toList $ V.map (\(Attribute name _) -> name) attrVec

170+attributeNameSet attrs = S.fromList $ V.toList $ V.map (\(Attribute name _) -> name) (attributesVec attrs)

98171

99172attributeNames :: Attributes -> V.Vector AttributeName

100−attributeNames = V.map attributeName

173+attributeNames attrs = V.map attributeName (attributesVec attrs)

101174

102175--checks if set s1 is wholly contained in the set s2

103176attributesContained :: Attributes -> Attributes -> Bool

@@ -118,42 +191,88 @@ attributeNamesNotContained subset superset = S.filter (`S.notMember` superset) s

118191

119192-- useful for display

120193orderedAttributes :: Attributes -> [Attribute]

121−orderedAttributes attrs = L.sortBy (\a b -> attributeName a `compare` attributeName b) (V.toList attrs)

194+orderedAttributes attrs = L.sortBy (\a b -> attributeName a `compare` attributeName b) (V.toList (attributesVec attrs))

122195

123196orderedAttributeNames :: Attributes -> [AttributeName]

124197orderedAttributeNames attrs = map attributeName (orderedAttributes attrs)

125198

126199-- take two attribute sets and return an attribute set with the attributes which do not match

200+--this is the function which benefits the most from the HashSet representation- this turned up in the insert performance test

127201attributesDifference :: Attributes -> Attributes -> Attributes

128−attributesDifference attrsA attrsB = V.fromList $ diff (V.toList attrsA) (V.toList attrsB)

202+{-attributesDifference attrsA attrsB = V.fromList $ diff (V.toList attrsA) (V.toList attrsB)

129203 where

130204 diff a b = (a L.\\ b) ++ (b L.\\ a)

205+-}

206+attributesDifference attrsA attrsB =

207+ if attributesSet attrsA == attributesSet attrsB then

208+ mempty

209+ else

210+ Attributes {

211+ attributesVec = vec

212+ --,attributesSet = hset

213+ }

214+ where

215+ hset = HS.difference setA setB <> HS.difference setB setA

216+ setA = attributesSet attrsA

217+ setB = attributesSet attrsB

218+ vec = V.filter (`HS.member` hset) (attributesVec attrsA <> attributesVec attrsB)

131219

132220vectorUniqueify :: (Hash.Hashable a, Eq a) => V.Vector a -> V.Vector a

133221vectorUniqueify vecIn = V.fromList $ HS.toList $ HS.fromList $ V.toList vecIn

134222

135223--check that each attribute only appears once

136224verifyAttributes :: Attributes -> Either RelationalError Attributes

137−verifyAttributes attrs = if collapsedAttrs /= attrs then

138− Left (TupleAttributeTypeMismatchError (attributesDifference collapsedAttrs attrs))

139− else

140− Right attrs

225+verifyAttributes attrs =

226+ if vecSet == attributesSet attrs then

227+ pure attrs

228+ else

229+ Left (TupleAttributeTypeMismatchError diffAttrs)

141230 where

142− collapsedAttrs = vectorUniqueify attrs

231+ vecSet = V.foldr' HS.insert HS.empty (attributesVec attrs)

232+ diffSet = HS.difference vecSet (attributesSet attrs) <> HS.difference (attributesSet attrs) vecSet

233+ diffAttrs = Attributes {

234+ attributesVec = V.fromList (HS.toList diffSet)

235+ --,attributesSet = diffSet

236+ }

237+

238+--used in Generics derivation for ADTs without named attributes- not to be used elsewhere

239+--drop first n attributes from vector representation

240+drop :: Int -> Attributes -> Attributes

241+drop c attrs = Attributes { attributesVec = vec

242+ }

243+ where

244+ vec = V.drop c (attributesVec attrs)

245+

246+

247+-- use this in preference to attributesEqual when the attribute ordering matters such as during tuple unions

248+attributesAndOrderEqual :: Attributes -> Attributes -> Bool

249+attributesAndOrderEqual a b = attributesVec a == attributesVec b

143250

251+-- use to determine if the same attributes are contained (but ordering is irrelevant)

144252attributesEqual :: Attributes -> Attributes -> Bool

145−attributesEqual attrs1 attrs2 = V.null (attributesDifference attrs1 attrs2)

253+attributesEqual attrsA attrsB =

254+ attributesVec attrsA == attributesVec attrsB ||

255+ attributesSet attrsA == attributesSet attrsB

146256

147257attributesAsMap :: Attributes -> M.Map AttributeName Attribute

148−attributesAsMap attrs = (M.fromList . V.toList) (V.map (\attr -> (attributeName attr, attr)) attrs)

258+attributesAsMap attrs = V.foldr' (\attr acc -> M.insert (attributeName attr) attr acc) mempty (attributesVec attrs)

259+

149260

150261-- | Left-biased union of attributes.

151262union :: Attributes -> Attributes -> Attributes

152−union attrsA attrsB = V.fromList (M.elems unioned)

263+union attrsA attrsB = Attributes {

264+ attributesVec = vec

265+ --,attributesSet = hset

266+ }

153267 where

154− unioned = M.union (attributesAsMap attrsA) (attributesAsMap attrsB)

268+ hset = HS.union (attributesSet attrsA) (attributesSet attrsB)

269+ vec = HS.foldr (flip V.snoc) mempty hset

155270

156271intersection :: Attributes -> Attributes -> Attributes

157−intersection attrsA attrsB = V.fromList (M.elems intersected)

272+intersection attrsA attrsB = Attributes {

273+ attributesVec = vec

274+ --,attributesSet = hset

275+ }

158276 where

159− intersected = M.intersection (attributesAsMap attrsA) (attributesAsMap attrsB)

277+ hset = HS.intersection (attributesSet attrsA) (attributesSet attrsB)

278+ vec = HS.foldr (flip V.snoc) mempty hset

src/lib/ProjectM36/Base.hs+113−107

@@ -1,10 +1,12 @@

1−{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveFoldable, DeriveFunctor, DeriveTraversable #-}

1+{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable, DerivingVia, TemplateHaskell, TypeFamilies #-}

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

44module ProjectM36.Base where

55import ProjectM36.DatabaseContextFunctionError

66import ProjectM36.AtomFunctionError

7+import ProjectM36.MerkleHash

9+import Data.Functor.Foldable.TH

810import qualified Data.Map as M

911import qualified Data.HashSet as HS

1012import Data.Hashable (Hashable, hashWithSalt)

@@ -17,16 +19,17 @@ import GHC.Stack

1719import qualified Data.Vector as V

1820import qualified Data.List as L

1921import Data.Text (Text,unpack)

20−import Data.Binary

21−import Data.Vector.Binary()

2222import Data.Time.Clock

23−import Data.Time.Clock.POSIX

24−import Data.Time.Calendar (Day,toGregorian,fromGregorian)

2523import Data.Hashable.Time ()

24+import Data.Time.Calendar (Day)

2625import Data.Typeable

2726import Data.ByteString (ByteString)

2827import qualified Data.List.NonEmpty as NE

28+import Data.Vector.Instances ()

29+

2930type StringType = Text

31+

32+type DatabaseName = String

3033

3134-- | Database atoms are the smallest, undecomposable units of a tuple. Common examples are integers, text, or unique identity keys.

3235data Atom = IntegerAtom Integer |

@@ -38,8 +41,9 @@ data Atom = IntegerAtom Integer |

3841 ByteStringAtom ByteString |

3942 BoolAtom Bool |

4043 RelationAtom Relation |

44+ RelationalExprAtom RelationalExpr | --used for returning inc deps

4145 ConstructedAtom DataConstructorName AtomType [Atom]

42− deriving (Eq, Show, Binary, Typeable, NFData, Generic)

46+ deriving (Eq, Show, Typeable, NFData, Generic, Read)

4347

4448instance Hashable Atom where

4549 hashWithSalt salt (ConstructedAtom dConsName _ atoms) = salt `hashWithSalt` atoms

@@ -53,16 +57,7 @@ instance Hashable Atom where

5357 hashWithSalt salt (ByteStringAtom bs) = salt `hashWithSalt` bs

5458 hashWithSalt salt (BoolAtom b) = salt `hashWithSalt` b

5559 hashWithSalt salt (RelationAtom r) = salt `hashWithSalt` r

56−

57−instance Binary UTCTime where

58− put utc = put $ toRational (utcTimeToPOSIXSeconds utc)

59− get = posixSecondsToUTCTime . fromRational <$> (get :: Get Rational)

60−

61−instance Binary Day where

62− put day = put $ toGregorian day

63− get = do

64− (y,m,d) <- get :: Get (Integer, Int, Int)

65− return (fromGregorian y m d)

60+ hashWithSalt salt (RelationalExprAtom re) = salt `hashWithSalt` re

6661

6762-- I suspect the definition of ConstructedAtomType with its name alone is insufficient to disambiguate the cases; for example, one could create a type named X, remove a type named X, and re-add it using different constructors. However, as long as requests are served from only one DatabaseContext at-a-time, the type name is unambiguous. This will become a problem for time-travel, however.

6863-- | The AtomType uniquely identifies the type of a atom.

@@ -76,12 +71,15 @@ data AtomType = IntAtomType |

7671 BoolAtomType |

7772 RelationAtomType Attributes |

7873 ConstructedAtomType TypeConstructorName TypeVarMap |

74+ RelationalExprAtomType |

7975 TypeVariableType TypeVarName

8076 --wildcard used in Atom Functions and tuples for data constructors which don't provide all arguments to the type constructor

81− deriving (Eq, NFData, Generic, Binary, Show)

77+ deriving (Eq, NFData, Generic, Show, Read, Hashable)

8278

8379instance Ord AtomType where

84− compare = undefined

80+ compare = undefined

81+

82+-- this should probably be an ordered dictionary in order to be able to round-trip these arguments

8583type TypeVarMap = M.Map TypeVarName AtomType

8684

8785instance Hashable TypeVarMap where

@@ -96,25 +94,37 @@ isRelationAtomType _ = False

9694type AttributeName = StringType

9795

9896-- | A relation's type is composed of attribute names and types.

99−data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic, NFData, Binary)

97+data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Read, Generic, NFData)

10098

10199instance Hashable Attribute where

102100 hashWithSalt salt (Attribute attrName _) = hashWithSalt salt attrName

103101

102+type AttributesHash = Int

103+

104104-- | 'Attributes' represent the head of a relation.

105−type Attributes = V.Vector Attribute

105+newtype Attributes = Attributes {

106+ attributesVec :: V.Vector Attribute

107+ --,attributesSet :: HS.HashSet Attribute --compare with this generated in heap profile and benchmarks

108+ }

109+ deriving (NFData, Read, Hashable, Generic)

110+

111+attributesSet :: Attributes -> HS.HashSet Attribute

112+attributesSet = HS.fromList . V.toList . attributesVec

113+

114+instance Show Attributes where

115+ show attrs = "attributesFromList [" <> L.intercalate ", " (map (\attr -> "(" <> show attr <> ")") (V.toList (attributesVec attrs))) <> "]"

116+

117+--when attribute ordering is irrelevant

118+instance Eq Attributes where

119+ attrsA == attrsB =

120+ attributesVec attrsA == attributesVec attrsB ||

121+ attributesSet attrsA == attributesSet attrsB

106122

107−-- | Equality function for a set of attributes.

108−attributesEqual :: Attributes -> Attributes -> Bool

109−attributesEqual attrs1 attrs2 = attrsAsSet attrs1 == attrsAsSet attrs2

110− where

111− attrsAsSet = HS.fromList . V.toList

112−

113123sortedAttributesIndices :: Attributes -> [(Int, Attribute)]

114−sortedAttributesIndices attrs = L.sortBy (\(_, Attribute name1 _) (_,Attribute name2 _) -> compare name1 name2) $ V.toList (V.indexed attrs)

124+sortedAttributesIndices attrs = L.sortBy (\(_, Attribute name1 _) (_,Attribute name2 _) -> compare name1 name2) $ V.toList (V.indexed (attributesVec attrs))

115125

116126-- | The relation's tuple set is the body of the relation.

117−newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Binary)

127+newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Read)

118128

119129instance Read Relation where

120130 readsPrec = error "relation read not supported"

@@ -130,8 +140,8 @@ instance NFData RelationTupleSet where rnf = genericRnf

130140instance Hashable RelationTuple where

131141 --sanity check the tuple for attribute and tuple counts

132142 --this bit me when tuples were being hashed before being verified

133− hashWithSalt salt (RelationTuple attrs tupVec) = if V.length attrs /= V.length tupVec then

134− error "invalid tuple: attributes and tuple count mismatch"

143+ hashWithSalt salt (RelationTuple attrs tupVec) = if V.length (attributesVec attrs) /= V.length tupVec then

144+ error ("invalid tuple: attributes and tuple count mismatch " <> show (attributesVec attrs, tupVec))

135145 else

136146 salt `hashWithSalt`

137147 sortedAttrs `hashWithSalt`

@@ -142,25 +152,23 @@ instance Hashable RelationTuple where

142152 sortedTupVec = V.map (\(index, _) -> tupVec V.! index) $ V.fromList sortedAttrsIndices

143153

144154-- | A tuple is a set of attributes mapped to their 'Atom' values.

145−data RelationTuple = RelationTuple Attributes (V.Vector Atom) deriving (Show, Generic)

146−

147−instance Binary RelationTuple

155+data RelationTuple = RelationTuple Attributes (V.Vector Atom) deriving (Show, Read, Generic)

148156

149157instance Eq RelationTuple where

150− (==) tuple1@(RelationTuple attrs1 _) tuple2@(RelationTuple attrs2 _) = attributesEqual attrs1 attrs2 && atomsEqual

158+ tuple1@(RelationTuple attrs1 _) == tuple2@(RelationTuple attrs2 _) =

159+ attrs1 == attrs2 && atomsEqual

151160 where

152− atomForAttribute attr (RelationTuple attrs tupVec) = case V.findIndex (== attr) attrs of

161+ atomForAttribute attr (RelationTuple attrs tupVec) = case V.findIndex (== attr) (attributesVec attrs) of

153162 Nothing -> Nothing

154163 Just index -> tupVec V.!? index

155− atomsEqual = V.all (== True) $ V.map (\attr -> atomForAttribute attr tuple1 == atomForAttribute attr tuple2) attrs1

164+ atomsEqual = V.all (== True) $ V.map (\attr -> atomForAttribute attr tuple1 == atomForAttribute attr tuple2) (attributesVec attrs1)

156165

157166instance NFData RelationTuple where rnf = genericRnf

158167

159−

160168data Relation = Relation Attributes RelationTupleSet deriving (Show, Generic,Typeable)

161169

162170instance Eq Relation where

163− Relation attrs1 tupSet1 == Relation attrs2 tupSet2 = attributesEqual attrs1 attrs2 && tupSet1 == tupSet2

171+ Relation attrs1 tupSet1 == Relation attrs2 tupSet2 = attrs1 == attrs2 && tupSet1 == tupSet2

164172

165173instance NFData Relation where rnf = genericRnf

166174

@@ -171,8 +179,6 @@ instance Hashable Relation where

171179 where

172180 sortedAttrs = map snd (sortedAttributesIndices attrs)

173181

174−instance Binary Relation

175−

176182-- | Used to represent the number of tuples in a relation.

177183data RelationCardinality = Countable | Finite Int deriving (Eq, Show, Generic, Ord)

178184

@@ -184,7 +190,7 @@ type RelationalExpr = RelationalExprBase ()

184190-- | A relational expression represents query (read) operations on a database.

185191data RelationalExprBase a =

186192 --- | Create a relation from tuple expressions.

187− MakeRelationFromExprs (Maybe [AttributeExprBase a]) [TupleExprBase a] |

193+ MakeRelationFromExprs (Maybe [AttributeExprBase a]) (TupleExprsBase a) |

188194 --- | Create and reference a relation from attributes and a tuple set.

189195 MakeStaticRelation Attributes RelationTupleSet |

190196 --- | Reference an existing relation in Haskell-space.

@@ -217,17 +223,15 @@ data RelationalExprBase a =

217223 --Summarize :: AtomExpr -> AttributeName -> RelationalExpr -> RelationalExpr -> RelationalExpr -- a special case of Extend

218224 --Evaluate relationalExpr with scoped views

219225 With [(WithNameExprBase a, RelationalExprBase a)] (RelationalExprBase a)

220− deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)

221−

222−instance Binary RelationalExpr

226+ deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable)

223227

228+instance Hashable RelationalExpr

229+

224230data WithNameExprBase a = WithNameExpr RelVarName a

225− deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)

231+ deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable, Hashable)

226232

227233type WithNameExpr = WithNameExprBase ()

228234

229−instance Binary WithNameExpr

230−

231235type GraphRefWithNameExpr = WithNameExprBase GraphRefTransactionMarker

232236

233237type NotificationName = StringType

@@ -239,22 +243,22 @@ data Notification = Notification {

239243 reportOldExpr :: RelationalExpr, --run the expression in the pre-change context

240244 reportNewExpr :: RelationalExpr --run the expression in the post-change context

241245 }

242− deriving (Show, Eq, Binary, Generic, NFData)

246+ deriving (Show, Eq, Generic, NFData)

243247

244248type TypeVarName = StringType

245249

246250-- | Metadata definition for type constructors such as @data Either a b@.

247251data TypeConstructorDef = ADTypeConstructorDef TypeConstructorName [TypeVarName] |

248252 PrimitiveTypeConstructorDef TypeConstructorName AtomType

249− deriving (Show, Generic, Binary, Eq, NFData)

253+ deriving (Show, Generic, Eq, NFData, Hashable, Read)

250254

251255-- | Found in data constructors and type declarations: Left (Either Int Text) | Right Int

252256type TypeConstructor = TypeConstructorBase ()

253257data TypeConstructorBase a = ADTypeConstructor TypeConstructorName [TypeConstructor] |

254− PrimitiveTypeConstructor TypeConstructorName AtomType |

255− RelationAtomTypeConstructor [AttributeExprBase a] |

256− TypeVariable TypeVarName

257− deriving (Show, Generic, Binary, Eq, NFData)

258+ PrimitiveTypeConstructor TypeConstructorName AtomType |

259+ RelationAtomTypeConstructor [AttributeExprBase a] |

260+ TypeVariable TypeVarName

261+ deriving (Show, Generic, Eq, NFData, Hashable, Read)

258262

259263type TypeConstructorMapping = [(TypeConstructorDef, DataConstructorDefs)]

260264

@@ -264,20 +268,20 @@ type DataConstructorName = StringType

264268type AtomTypeName = StringType

265269

266270-- | Used to define a data constructor in a type constructor context such as @Left a | Right b@

267−data DataConstructorDef = DataConstructorDef DataConstructorName [DataConstructorDefArg] deriving (Eq, Show, Binary, Generic, NFData)

271+data DataConstructorDef = DataConstructorDef DataConstructorName [DataConstructorDefArg] deriving (Eq, Show, Generic, NFData, Hashable, Read)

268272

269273type DataConstructorDefs = [DataConstructorDef]

270274

271275data DataConstructorDefArg = DataConstructorDefTypeConstructorArg TypeConstructor |

272276 DataConstructorDefTypeVarNameArg TypeVarName

273− deriving (Show, Generic, Binary, Eq, NFData)

277+ deriving (Show, Generic, Eq, NFData, Hashable, Read)

274278

275279type InclusionDependencies = M.Map IncDepName InclusionDependency

276280type RelationVariables = M.Map RelVarName GraphRefRelationalExpr

277281

278282data GraphRefTransactionMarker = TransactionMarker TransactionId |

279283 UncommittedContextMarker

280− deriving (Eq, Show, Binary, Generic, NFData, Ord)

284+ deriving (Eq, Show, Generic, NFData, Ord)

281285

282286-- a fundamental relational expr to which other relational expressions compile

283287type GraphRefRelationalExpr = RelationalExprBase GraphRefTransactionMarker

@@ -288,17 +292,18 @@ type Subschemas = M.Map SchemaName Schema

288292

289293-- | Every transaction has one concrete database context and any number of isomorphic subschemas.

290294data Schemas = Schemas DatabaseContext Subschemas

295+ deriving (Generic)

291296

292297-- | The DatabaseContext is a snapshot of a database's evolving state and contains everything a database client can change over time.

293298-- I spent some time thinking about whether the VirtualDatabaseContext/Schema and DatabaseContext data constructors should be the same constructor, but that would allow relation variables to be created in a "virtual" context which would appear to defeat the isomorphisms of the contexts. It should be possible to switch to an alternative schema to view the same equivalent information without information loss. However, allowing all contexts to reference another context while maintaining its own relation variables, new types, etc. could be interesting from a security perspective. For example, if a user creates a new relvar in a virtual context, then does it necessarily appear in all linked contexts? After deliberation, I think the relvar should appear in *all* linked contexts to retain the isomorphic properties, even when the isomorphism is for a subset of the context. This hints that the IsoMorphs should allow for "fall-through"; that is, when a relvar is not defined in the virtual context (for morphing), then the lookup should fall through to the underlying context.

294299newtype Schema = Schema SchemaIsomorphs

295− deriving (Generic, Binary)

300+ deriving (Generic)

296301

297302data SchemaIsomorph = IsoRestrict RelVarName RestrictionPredicateExpr (RelVarName, RelVarName) |

298303 IsoRename RelVarName RelVarName |

299304 IsoUnion (RelVarName, RelVarName) RestrictionPredicateExpr RelVarName --maps two relvars to one relvar

300305 -- IsoTypeConstructor in morphAttrExpr

301− deriving (Generic, Binary, Show)

306+ deriving (Generic, Show)

302307

303308type SchemaIsomorphs = [SchemaIsomorph]

304309

@@ -314,9 +319,7 @@ data DatabaseContext = DatabaseContext {

314319type IncDepName = StringType

315320

316321-- | Inclusion dependencies represent every possible database constraint. Constraints enforce specific, arbitrarily-complex rules to which the database context's relation variables must adhere unconditionally.

317−data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show, Eq, Generic, NFData)

318−

319−instance Binary InclusionDependency

322+data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show, Eq, Generic, NFData, Hashable, Read)

320323

321324type AttributeNameAtomExprMap = M.Map AttributeName AtomExpr

322325

@@ -325,9 +328,9 @@ type DatabaseContextExprName = StringType

325328

326329type DatabaseContextExpr = DatabaseContextExprBase ()

327330

328−type GraphRefDatabaseContextExpr = DatabaseContextExprBase GraphRefTransactionMarker

331+instance Hashable DatabaseContextExpr

329332

330−instance Binary GraphRefDatabaseContextExpr

333+type GraphRefDatabaseContextExpr = DatabaseContextExprBase GraphRefTransactionMarker

331334

332335-- | Database context expressions modify the database context.

333336data DatabaseContextExprBase a =

@@ -356,9 +359,10 @@ data DatabaseContextExprBase a =

356359 ExecuteDatabaseContextFunction DatabaseContextFunctionName [AtomExprBase a] |

357360

358361 MultipleExpr [DatabaseContextExprBase a]

359− deriving (Show, Eq, Generic)

362+ deriving (Show, Read, Eq, Generic, NFData)

360363

361−instance Binary DatabaseContextExpr

364+instance Hashable (M.Map AttributeName AtomExpr) where

365+ hashWithSalt salt m = salt `hashWithSalt` M.toList m

362366

363367type ObjModuleName = StringType

364368type ObjFunctionName = StringType

@@ -370,7 +374,7 @@ data DatabaseContextIOExprBase a =

370374 AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript |

371375 LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath |

372376 CreateArbitraryRelation RelVarName [AttributeExprBase a] Range

373− deriving (Show, Eq, Generic, Binary)

377+ deriving (Show, Eq, Generic)

374378

375379type GraphRefDatabaseContextIOExpr = DatabaseContextIOExprBase GraphRefTransactionMarker

376380

@@ -378,6 +382,8 @@ type DatabaseContextIOExpr = DatabaseContextIOExprBase ()

378382

379383type RestrictionPredicateExpr = RestrictionPredicateExprBase ()

380384

385+instance Hashable RestrictionPredicateExpr

386+

381387type GraphRefRestrictionPredicateExpr = RestrictionPredicateExprBase GraphRefTransactionMarker

382388

383389-- | Restriction predicates are boolean algebra components which, when composed, indicate whether or not a tuple should be retained during a restriction (filtering) operation.

@@ -389,9 +395,7 @@ data RestrictionPredicateExprBase a =

389395 RelationalExprPredicate (RelationalExprBase a) | --type must be same as true and false relations (no attributes)

390396 AtomExprPredicate (AtomExprBase a) | --atom must evaluate to boolean

391397 AttributeEqualityPredicate AttributeName (AtomExprBase a) -- relationalexpr must result in relation with single tuple

392− deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)

393−

394−instance Binary RestrictionPredicateExpr

398+ deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable)

395399

396400-- child + parent links

397401-- | A transaction graph's head name references the leaves of the transaction graph and can be used during session creation to indicate at which point in the graph commits should persist.

@@ -401,6 +405,7 @@ type TransactionHeads = M.Map HeadName Transaction

401405

402406-- | The transaction graph is the global database's state which references every committed transaction.

403407data TransactionGraph = TransactionGraph TransactionHeads (S.Set Transaction)

408+ deriving Generic

404409

405410transactionHeadsForGraph :: TransactionGraph -> TransactionHeads

406411transactionHeadsForGraph (TransactionGraph hs _) = hs

@@ -412,7 +417,8 @@ transactionsForGraph (TransactionGraph _ ts) = ts

412417-- The `TransactionDiff`s represent child/edge relationships to previous transactions (branches or continuations of the same branch).

413418data TransactionInfo = TransactionInfo {

414419 parents :: TransactionParents,

415− stamp :: UTCTime

420+ stamp :: UTCTime,

421+ merkleHash :: MerkleHash

416422 } deriving (Show, Generic)

417423

418424type TransactionParents = NE.NonEmpty TransactionId

@@ -422,16 +428,15 @@ data TransactionInfo = TransactionInfo TransactionId TransactionDiffs UTCTime |

422428 deriving (Show, Generic)

423429-}

424430

425−instance Binary TransactionInfo

426−

427431-- | Every set of modifications made to the database are atomically committed to the transaction graph as a transaction.

428432type TransactionId = UUID

429433

430434data Transaction = Transaction TransactionId TransactionInfo Schemas

435+ deriving Generic

431436

432437-- | The disconnected transaction represents an in-progress workspace used by sessions before changes are committed. This is similar to git's "index". After a transaction is committed, it is "connected" in the transaction graph and can no longer be modified.

433−data DisconnectedTransaction = DisconnectedTransaction TransactionId Schemas DatabaseContextExpr

434−--the database context expression represents a difference between the disconnected transaction and its immutable parent transaction

438+data DisconnectedTransaction = DisconnectedTransaction TransactionId Schemas DirtyFlag

439+--the database context expression represents a difference between the disconnected transaction and its immutable parent transaction- is this diff expr used at all?

435440

436441type DirtyFlag = Bool

437442

@@ -451,6 +456,8 @@ instance Ord Transaction where

451456

452457type AtomExpr = AtomExprBase ()

453458

459+instance Hashable AtomExpr

460+

454461type GraphRefAtomExpr = AtomExprBase GraphRefTransactionMarker

455462

456463-- | An atom expression represents an action to take when extending a relation or when statically defining a relation or a new tuple.

@@ -459,18 +466,17 @@ data AtomExprBase a = AttributeAtomExpr AttributeName |

459466 FunctionAtomExpr AtomFunctionName [AtomExprBase a] a |

460467 RelationAtomExpr (RelationalExprBase a) |

461468 ConstructedAtomExpr DataConstructorName [AtomExprBase a] a

462− deriving (Eq,Show,Generic, NFData, Foldable, Functor, Traversable)

469+ deriving (Eq, Show, Read, Generic, NFData, Foldable, Functor, Traversable)

463470

464−instance Binary AtomExpr

465−

466471-- | Used in tuple creation when creating a relation.

467472data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)

468− deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)

473+ deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable)

469474

470475type ExtendTupleExpr = ExtendTupleExprBase ()

471−type GraphRefExtendTupleExpr = ExtendTupleExprBase GraphRefTransactionMarker

472476

473−instance Binary ExtendTupleExpr

477+instance Hashable ExtendTupleExpr

478+

479+type GraphRefExtendTupleExpr = ExtendTupleExprBase GraphRefTransactionMarker

474480

475481--enumerates the list of functions available to be run as part of tuple expressions

476482type AtomFunctions = HS.HashSet AtomFunction

@@ -482,6 +488,7 @@ type AtomFunctionBodyScript = StringType

482488type AtomFunctionBodyType = [Atom] -> Either AtomFunctionError Atom

483489

484490data AtomFunctionBody = AtomFunctionBody (Maybe AtomFunctionBodyScript) AtomFunctionBodyType

491+ deriving Generic

485492

486493instance NFData AtomFunctionBody where

487494 rnf (AtomFunctionBody mScript _) = rnf mScript

@@ -516,14 +523,17 @@ data AttributeNamesBase a = AttributeNames (S.Set AttributeName) |

516523 UnionAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) |

517524 IntersectAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) |

518525 RelationalExprAttributeNames (RelationalExprBase a) -- use attribute names from the relational expression's type

519− deriving (Eq, Show, Generic, NFData, Foldable, Functor, Traversable)

526+ deriving (Eq, Show, Read, Generic, NFData, Foldable, Functor, Traversable)

527+

528+instance Hashable AttributeNames

529+

530+instance Hashable (S.Set AttributeName) where

531+ hashWithSalt salt s = salt `hashWithSalt` S.toList s

520532

521533type AttributeNames = AttributeNamesBase ()

522534

523535type GraphRefAttributeNames = AttributeNamesBase GraphRefTransactionMarker

524536

525−instance Binary AttributeNames

526−

527537-- | The persistence strategy is a global database option which represents how to persist the database in the filesystem, if at all.

528538data PersistenceStrategy = NoPersistence | -- ^ no filesystem persistence/memory-only database

529539 MinimalPersistence FilePath | -- ^ fsync off, not crash-safe

@@ -536,18 +546,27 @@ type GraphRefAttributeExpr = AttributeExprBase GraphRefTransactionMarker

536546-- | Create attributes dynamically.

537547data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a |

538548 NakedAttributeExpr Attribute

539− deriving (Eq, Show, Generic, Binary, NFData, Foldable, Functor, Traversable)

549+ deriving (Eq, Show, Read, Generic, NFData, Foldable, Functor, Traversable, Hashable)

540550

541551-- | Dynamically create a tuple from attribute names and 'AtomExpr's.

542552newtype TupleExprBase a = TupleExpr (M.Map AttributeName (AtomExprBase a))

543− deriving (Eq, Show, Generic, NFData, Foldable, Functor, Traversable)

544−

545−instance Binary TupleExpr

553+ deriving (Eq, Show, Read, Generic, NFData, Foldable, Functor, Traversable)

554+

555+instance Hashable TupleExpr

546556

547557type TupleExpr = TupleExprBase ()

548558

549559type GraphRefTupleExpr = TupleExprBase GraphRefTransactionMarker

550560

561+data TupleExprsBase a = TupleExprs a [TupleExprBase a]

562+ deriving (Eq, Show, Read, Generic, NFData, Foldable, Functor, Traversable)

563+

564+instance Hashable TupleExprs

565+

566+type GraphRefTupleExprs = TupleExprsBase GraphRefTransactionMarker

567+

568+type TupleExprs = TupleExprsBase ()

569+

551570data MergeStrategy =

552571 -- | After a union merge, the merge transaction is a result of union'ing relvars of the same name, introducing all uniquely-named relvars, union of constraints, union of atom functions, notifications, and types (unless the names and definitions collide, e.g. two types of the same name with different definitions)

553572 UnionMergeStrategy |

@@ -555,7 +574,7 @@ data MergeStrategy =

555574 UnionPreferMergeStrategy HeadName |

556575 -- | Similar to the our/theirs merge strategy in git, the merge transaction's context is identical to that of the last transaction in the selected branch.

557576 SelectedBranchMergeStrategy HeadName

558− deriving (Eq, Show, Binary, Generic, NFData)

577+ deriving (Eq, Show, Generic, NFData)

559578

560579type DatabaseContextFunctionName = StringType

561580

@@ -592,7 +611,8 @@ attrTypeVars (Attribute _ aType) = case aType of

592611 DateTimeAtomType -> S.empty

593612 ByteStringAtomType -> S.empty

594613 BoolAtomType -> S.empty

595− (RelationAtomType attrs) -> S.unions (map attrTypeVars (V.toList attrs))

614+ RelationalExprAtomType -> S.empty

615+ (RelationAtomType attrs) -> S.unions (map attrTypeVars (V.toList (attributesVec attrs)))

596616 (ConstructedAtomType _ tvMap) -> M.keysSet tvMap

597617 (TypeVariableType nam) -> S.singleton nam

598618

@@ -615,26 +635,12 @@ atomTypeVars DayAtomType = S.empty

615635atomTypeVars DateTimeAtomType = S.empty

616636atomTypeVars ByteStringAtomType = S.empty

617637atomTypeVars BoolAtomType = S.empty

618−atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList attrs))

638+atomTypeVars RelationalExprAtomType = S.empty

639+atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList (attributesVec attrs)))

619640atomTypeVars (ConstructedAtomType _ tvMap) = M.keysSet tvMap

620641atomTypeVars (TypeVariableType nam) = S.singleton nam

621642

622643unimplemented :: HasCallStack => a

623−unimplemented = undefined

624−

625−--for serializing GraphRefRelationalExpr as part of transaction serialization

626−instance Binary (TupleExprBase GraphRefTransactionMarker)

627−

628−instance Binary GraphRefRelationalExpr

629−

630−instance Binary (AtomExprBase GraphRefTransactionMarker)

631−

632−instance Binary (AttributeNamesBase GraphRefTransactionMarker)

633−

634−instance Binary (RestrictionPredicateExprBase GraphRefTransactionMarker)

635−

636−instance Binary (ExtendTupleExprBase GraphRefTransactionMarker)

637−

638−instance Binary GraphRefWithNameExpr

644+unimplemented = error "unimplemented"

639645

640−

646+makeBaseFunctor ''RelationalExprBase

src/lib/ProjectM36/Client.hs+195−309

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

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

1+{-# LANGUAGE DeriveGeneric, ScopedTypeVariables, MonoLocalBinds, DerivingVia #-}

22{-|

33Module: ProjectM36.Client

@@ -9,6 +9,7 @@ module ProjectM36.Client

99 Connection(..),

1010 Port,

1111 Hostname,

12+ ServiceName,

1213 DatabaseName,

1314 ConnectionError(..),

1415 connectProjectM36,

@@ -43,6 +44,7 @@ module ProjectM36.Client

4344 defaultDatabaseName,

4445 defaultRemoteConnectionInfo,

4546 defaultHeadName,

47+ addClientNode,

4648 PersistenceStrategy(..),

4749 RelationalExpr,

4850 RelationalExprBase(..),

@@ -53,11 +55,9 @@ module ProjectM36.Client

5355 Attribute(..),

5456 MergeStrategy(..),

5557 attributesFromList,

56− createNodeId,

5758 createSessionAtCommit,

5859 createSessionAtHead,

5960 closeSession,

60− addClientNode,

6161 callTestTimeout_,

6262 RelationCardinality(..),

6363 TransactionGraphOperator(..),

@@ -67,7 +67,6 @@ module ProjectM36.Client

6767 TransGraphRelationalExpr,

6868 TransactionIdLookup(..),

6969 TransactionIdHeadBacktrack(..),

70− NodeId(..),

7170 Atom(..),

7271 Session,

7372 SessionId,

@@ -80,6 +79,7 @@ module ProjectM36.Client

8079 databaseContextExprForUniqueKey,

8180 databaseContextExprForForeignKey,

8281 createScriptedAtomFunction,

82+ ProjectM36.Client.validateMerkleHashes,

8383 AttributeExprBase(..),

8484 TypeConstructorBase(..),

8585 TypeConstructorDef(..),

@@ -99,12 +99,14 @@ module ProjectM36.Client

9999 AtomType(..),

100100 Atomable(..),

101101 TupleExprBase(..),

102+ TupleExprsBase(..),

102103 AtomExprBase(..),

103104 RestrictionPredicateExprBase(..),

104105 withTransaction

105106 ) where

106107import ProjectM36.Base hiding (inclusionDependencies) --defined in this module as well

107108import qualified ProjectM36.Base as B

109+import ProjectM36.Serialise.Error ()

108110import ProjectM36.Error

109111import ProjectM36.Atomable

110112import ProjectM36.AtomFunction as AF

@@ -117,7 +119,7 @@ import Control.Monad.State

117119import qualified ProjectM36.RelationalExpression as RE

118120import ProjectM36.DatabaseContext (basicDatabaseContext)

119121import qualified ProjectM36.TransactionGraph as Graph

120−import ProjectM36.TransactionGraph

122+import ProjectM36.TransactionGraph as TG

121123import qualified ProjectM36.Transaction as Trans

122124import ProjectM36.TransactionGraph.Persist

123125import ProjectM36.Attribute

@@ -132,28 +134,16 @@ import ProjectM36.Relation (typesAsRelation)

132134import ProjectM36.ScriptSession (initScriptSession, ScriptSession)

133135import qualified ProjectM36.Relation as R

134136import Control.Exception.Base

135−import GHC.Conc.Sync

136−

137−import Network.Transport (Transport(closeTransport))

138−#if MIN_VERSION_network_transport_tcp(0,7,0)

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

140−import Network.Transport.TCP.Internal (encodeEndPointAddress)

141−#elif MIN_VERSION_network_transport_tcp(0,6,0)

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

143−import Network.Transport.TCP.Internal (encodeEndPointAddress)

144−#else

145−import Network.Transport.TCP (encodeEndPointAddress, createTransport, defaultTCPParameters)

146−#endif

137+import Control.Concurrent.STM

138+import Control.Concurrent.Async

147139

148−import Control.Distributed.Process.Node (newLocalNode, initRemoteTable, runProcess, LocalNode, forkProcess, closeLocalNode)

149−import Control.Distributed.Process.Extras.Internal.Types (whereisRemote)

150−import Control.Distributed.Process.ManagedProcess.Client (call, safeCall)

151140import Data.Either (isRight)

152141import Data.UUID.V4 (nextRandom)

153142import Data.Word

154−import Control.Distributed.Process (ProcessId, Process, receiveWait, send, match, NodeId(..), reconnect)

143+import Data.Hashable

155144import Control.Exception (IOException, handle, AsyncException, throwIO, fromException, Exception)

156145import Control.Concurrent.MVar

146+import Codec.Winery hiding (Schema, schema)

157147import qualified Data.Map as M

158148#if MIN_VERSION_stm_containers(1,0,0)

159149import qualified StmContainers.Map as StmMap

@@ -165,20 +155,19 @@ import qualified STMContainers.Set as StmSet

165155import qualified ProjectM36.Session as Sess

166156import ProjectM36.Session

167157import ProjectM36.Sessions

168−--import "list-t" ListT

169−import Data.Binary (Binary)

170158import GHC.Generics (Generic)

171159import Control.DeepSeq (force)

172160import System.IO

173161import Data.Time.Clock

174−import Data.Typeable

162+import qualified Network.RPC.Curryer.Client as RPC

163+import qualified Network.RPC.Curryer.Server as RPC

164+import Network.Socket (Socket, AddrInfo(..), getAddrInfo, defaultHints, AddrInfoFlag(..), SocketType(..), ServiceName, hostAddressToTuple, SockAddr(..))

165+import GHC.Conc (unsafeIOToSTM)

175166

176167type Hostname = String

177168

178169type Port = Word16

179170

180−type DatabaseName = String

181−

182171-- | The type for notifications callbacks in the client. When a registered notification fires due to a changed relational expression evaluation, the server propagates the notifications to the clients in the form of the callback.

183172type NotificationCallback = NotificationName -> EvaluatedNotification -> IO ()

184173

@@ -198,15 +187,16 @@ data RequestTimeoutException = RequestTimeoutException

198187

199188instance Exception RequestTimeoutException

200189

201−-- | Construct a 'ConnectionInfo' to describe how to make the 'Connection'. The database can be run within the current process or running remotely via distributed-process.

202−data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy NotificationCallback [GhcPkgPath]|

203− RemoteProcessConnectionInfo DatabaseName NodeId NotificationCallback

190+-- | Construct a 'ConnectionInfo' to describe how to make the 'Connection'. The database can be run within the current process or running remotely via RPC.

191+data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy NotificationCallback [GhcPkgPath] |

192+ RemoteConnectionInfo DatabaseName Hostname ServiceName NotificationCallback

204193

205194type EvaluatedNotifications = M.Map NotificationName EvaluatedNotification

206195

207196-- | Used for callbacks from the server when monitored changes have been made.

208197newtype NotificationMessage = NotificationMessage EvaluatedNotifications

209− deriving (Binary, Eq, Show, Generic)

198+ deriving (Eq, Show, Generic)

199+ deriving Serialise via WineryVariant NotificationMessage

210200

211201-- | When a notification is fired, the 'reportOldExpr' is evaluated in the commit's pre-change context while the 'reportNewExpr' is evaluated in the post-change context and they are returned along with the original notification.

212202data EvaluatedNotification = EvaluatedNotification {

@@ -214,13 +204,10 @@ data EvaluatedNotification = EvaluatedNotification {

214204 reportOldRelation :: Either RelationalError Relation,

215205 reportNewRelation :: Either RelationalError Relation

216206 }

217− deriving(Binary, Eq, Show, Generic)

207+ deriving (Eq, Show, Generic)

208+ deriving Serialise via WineryRecord EvaluatedNotification

218209

219210

220−-- | Create a 'NodeId' for use in connecting to a remote server using distributed-process.

221−createNodeId :: Hostname -> Port -> NodeId

222−createNodeId host port = NodeId $ encodeEndPointAddress host (show port) 1

223−

224211-- | Use this for connecting to remote servers on the default port.

225212defaultServerPort :: Port

226213defaultServerPort = 6543

@@ -235,87 +222,36 @@ defaultHeadName = "master"

235222

236223-- | Create a connection configuration which connects to the localhost on the default server port and default server database name. The configured notification callback is set to ignore all events.

237224defaultRemoteConnectionInfo :: ConnectionInfo

238−defaultRemoteConnectionInfo = RemoteProcessConnectionInfo defaultDatabaseName (createNodeId "127.0.0.1" defaultServerPort) emptyNotificationCallback

225+defaultRemoteConnectionInfo =

226+ RemoteConnectionInfo defaultDatabaseName defaultServerHostname (show defaultServerPort) emptyNotificationCallback

239227

240−-- | The 'Connection' represents either local or remote access to a database. All operations flow through the connection.

241−type ClientNodes = StmSet.Set ProcessId

228+defaultServerHostname :: Hostname

229+defaultServerHostname = "localhost"

242230

243−-- internal structure specific to in-process connections

244−data InProcessConnectionConf = InProcessConnectionConf {

245− ipPersistenceStrategy :: PersistenceStrategy,

246− ipClientNodes :: ClientNodes,

247− ipSessions :: Sessions,

248− ipTransactionGraph :: TVar TransactionGraph,

249− ipScriptSession :: Maybe ScriptSession,

250− ipLocalNode :: LocalNode,

251− ipTransport :: Transport, -- we hold onto this so that we can close it gracefully

252− ipLocks :: Maybe (LockFile, MVar LockFileHash) -- nothing when NoPersistence

253− }

254−

255−data RemoteProcessConnectionConf = RemoteProcessConnectionConf {

256− rLocalNode :: LocalNode,

257− rProcessId :: ProcessId, --remote processId

258− rTransport :: Transport --the TCP socket transport

259− }

231+newtype RemoteConnectionConf = RemoteConnectionConf RPC.Connection

260232

261233data Connection = InProcessConnection InProcessConnectionConf |

262− RemoteProcessConnection RemoteProcessConnectionConf

234+ RemoteConnection RemoteConnectionConf

263235

264236-- | There are several reasons why a connection can fail.

265237data ConnectionError = SetupDatabaseDirectoryError PersistenceError |

266238 IOExceptionError IOException |

267239 NoSuchDatabaseByNameError DatabaseName |

240+ DatabaseValidationError [MerkleValidationError] |

268241 LoginError

269242 deriving (Show, Eq, Generic)

270243

271244remoteDBLookupName :: DatabaseName -> String

272245remoteDBLookupName = (++) "db-"

273246

274−createLocalNode :: IO (LocalNode, Transport)

275−createLocalNode = do

276−#if MIN_VERSION_network_transport_tcp(0,7,0)

277− let addrInfo = TCPAddrInfo {

278− tcpBindHost = "127.0.0.1",

279− tcpBindPort = "0",

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

281− }

282− eLocalTransport <- createTransport (Addressable addrInfo) defaultTCPParameters

283−#elif MIN_VERSION_network_transport_tcp(0,6,0)

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

285−#else

286− eLocalTransport <- createTransport "127.0.0.1" "0" defaultTCPParameters

287−#endif

288− case eLocalTransport of

289− Left err -> error ("failed to create transport: " ++ show err)

290− Right localTransport -> do

291− localNode <- newLocalNode localTransport initRemoteTable

292− pure (localNode, localTransport)

293−

294−notificationListener :: NotificationCallback -> Process ()

295−notificationListener callback = do

296− --pid <- getSelfPid

297− --liftIO $ putStrLn $ "LISTENER THREAD START " ++ show pid

298− _ <- forever $

299− receiveWait [

300− match (\(NotificationMessage eNots) ->

301− --say $ "NOTIFICATION: " ++ show eNots

302− -- when notifications are thrown, they are not adjusted for the current schema which could be problematic, but we don't have access to the current session here

303− liftIO $ mapM_ (uncurry callback) (M.toList eNots)

304− )

305− ]

306− --say "LISTENER THREAD EXIT"

307− pure ()

308−

309−startNotificationListener :: LocalNode -> NotificationCallback -> IO ProcessId

310−startNotificationListener localNode callback = forkProcess localNode (notificationListener callback)

311−

312247createScriptSession :: [String] -> IO (Maybe ScriptSession)

313248createScriptSession ghcPkgPaths = do

314249 eScriptSession <- initScriptSession ghcPkgPaths

315250 case eScriptSession of

316− Left err -> hPutStrLn stderr ("Failed to load scripting engine- scripting disabled: " ++ show err) >> pure Nothing --not a fatal error, but the scripting feature must be disabled

251+ Left err -> hPutStrLn stderr ("Warning: Haskell scripting disabled: " ++ show err) >> pure Nothing --not a fatal error, but the scripting feature must be disabled

317252 Right s -> pure (Just s)

318253

254+

319255-- | To create a 'Connection' to a remote or local database, create a 'ConnectionInfo' and call 'connectProjectM36'.

320256connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection)

321257--create a new in-memory database/transaction graph

@@ -330,42 +266,63 @@ connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPath

330266 graphTvar <- newTVarIO freshGraph

331267 clientNodes <- StmSet.newIO

332268 sessions <- StmMap.newIO

333− (localNode, transport) <- createLocalNode

334− notificationPid <- startNotificationListener localNode notificationCallback

335269 mScriptSession <- createScriptSession ghcPkgPaths

336−

270+ notifAsync <- startNotificationListener clientNodes notificationCallback

337271 let conn = InProcessConnection InProcessConnectionConf {

338272 ipPersistenceStrategy = strat,

339273 ipClientNodes = clientNodes,

340274 ipSessions = sessions,

341275 ipTransactionGraph = graphTvar,

342276 ipScriptSession = mScriptSession,

343− ipLocalNode = localNode,

344− ipTransport = transport,

345− ipLocks = Nothing}

346− addClientNode conn notificationPid

277+ ipLocks = Nothing,

278+ ipCallbackAsync = notifAsync

279+ }

347280 pure (Right conn)

348281 MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph notificationCallback ghcPkgPaths

349282 CrashSafePersistence dbdir -> connectPersistentProjectM36 strat FsyncDiskSync dbdir freshGraph notificationCallback ghcPkgPaths

350283

351−connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId notificationCallback) = do

352− connStatus <- newEmptyMVar

353− (localNode, transport) <- createLocalNode

354− let dbName = remoteDBLookupName databaseName

355− --putStrLn $ "Connecting to " ++ show serverNodeId ++ " " ++ dbName

356− notificationListenerPid <- startNotificationListener localNode notificationCallback

357− runProcess localNode $ do

358− --even a failed connection retains an open socket!

359− mServerProcessId <- whereisRemote serverNodeId dbName

360− case mServerProcessId of

361− Nothing -> liftIO $ putMVar connStatus $ Left (NoSuchDatabaseByNameError databaseName)

362− Just serverProcessId -> do

363− loginConfirmation <- safeLogin (Login notificationListenerPid) serverProcessId

364− if not loginConfirmation then

365− liftIO $ putMVar connStatus (Left LoginError)

366− else

367− liftIO $ putMVar connStatus (Right $ RemoteProcessConnection RemoteProcessConnectionConf {rLocalNode = localNode, rProcessId = serverProcessId, rTransport = transport})

368− takeMVar connStatus

284+connectProjectM36 (RemoteConnectionInfo dbName hostName servicePort notificationCallback) = do

285+ --TODO- add notification callback thread

286+ let resolutionHints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV],

287+ addrSocketType = Stream

288+ }

289+ resolved <- getAddrInfo (Just resolutionHints) (Just hostName) (Just servicePort)

290+ case resolved of

291+ [] -> error ("DNS resolution failed for" <> hostName <> ":" <> servicePort)

292+ addrInfo:_ -> do

293+ --supports IPv4 only for now

294+ let (SockAddrInet port addr) = addrAddress addrInfo

295+ notificationHandlers =

296+ [RPC.ClientAsyncRequestHandler $

297+ \(NotificationMessage notifications') ->

298+ forM_ (M.toList notifications') (uncurry notificationCallback)

299+ ]

300+ let connectExcHandler (e :: IOException) = pure $ Left (IOExceptionError e)

301+ eConn <- (Right <$> RPC.connect notificationHandlers (hostAddressToTuple addr) port) `catch` connectExcHandler

302+ case eConn of

303+ Left err -> pure (Left err)

304+ Right conn -> do

305+ eRet <- RPC.call conn (Login dbName)

306+ case eRet of

307+ Left err -> error (show err)

308+ Right False -> error "wtf"

309+ Right True ->

310+ --TODO handle connection errors!

311+ pure (Right (RemoteConnection (RemoteConnectionConf conn)))

312+

313+--convert RPC errors into exceptions

314+convertRPCErrors :: RPC.ConnectionError -> IO a

315+convertRPCErrors err =

316+ case err of

317+ RPC.TimeoutError -> throw RequestTimeoutException

318+ RPC.CodecError msg -> error $ "decoding message failed on server: " <> msg

319+ RPC.ExceptionError msg -> error $ "server threw exception: " <> msg

320+

321+addClientNode :: Connection -> RPC.Locking Socket -> IO ()

322+addClientNode (RemoteConnection _) _ = error "addClientNode called on remote connection"

323+addClientNode (InProcessConnection conf) lockSock = atomically (StmSet.insert clientInfo (ipClientNodes conf))

324+ where

325+ clientInfo = RemoteClientInfo lockSock

369326

370327connectPersistentProjectM36 :: PersistenceStrategy ->

371328 DiskSync ->

@@ -384,32 +341,40 @@ connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback ghc

384341 case graph of

385342 Left err' -> return $ Left (SetupDatabaseDirectoryError err')

386343 Right graph' -> do

387− tvarGraph <- newTVarIO graph'

388− sessions <- StmMap.newIO

389− clientNodes <- StmSet.newIO

390− (localNode, transport) <- createLocalNode

391− lockMVar <- newMVar digest

392− let conn = InProcessConnection InProcessConnectionConf {

344+ case TG.validateMerkleHashes graph' of

345+ Left merkleErrs -> pure (Left (DatabaseValidationError merkleErrs))

346+ Right _ -> do

347+ tvarGraph <- newTVarIO graph'

348+ sessions <- StmMap.newIO

349+ clientNodes <- StmSet.newIO

350+ lockMVar <- newMVar digest

351+ notifAsync <- startNotificationListener clientNodes notificationCallback

352+ let conn = InProcessConnection InProcessConnectionConf {

393353 ipPersistenceStrategy = strat,

394354 ipClientNodes = clientNodes,

395355 ipSessions = sessions,

396356 ipTransactionGraph = tvarGraph,

397357 ipScriptSession = mScriptSession,

398− ipLocalNode = localNode,

399− ipTransport = transport,

400− ipLocks = Just (lockFileH, lockMVar)

358+ ipLocks = Just (lockFileH, lockMVar),

359+ ipCallbackAsync = notifAsync

401360 }

361+ pure (Right conn)

362+

363+--startup local async process to handle notification callbacks

364+startNotificationListener :: ClientNodes -> NotificationCallback -> IO (Async ())

365+startNotificationListener cNodes notificationCallback = do

366+ inProcessClientInfo@(InProcessClientInfo notifMVar) <- InProcessClientInfo <$> newEmptyMVar

367+ atomically $ StmSet.insert inProcessClientInfo cNodes

368+ async $ forever $ do

369+ notifs <- takeMVar notifMVar

370+ forM_ (M.toList notifs) $ uncurry notificationCallback

402371

403− notificationPid <- startNotificationListener localNode notificationCallback

404− addClientNode conn notificationPid

405− pure (Right conn)

406−

407372-- | Create a new session at the transaction id and return the session's Id.

408373createSessionAtCommit :: Connection -> TransactionId -> IO (Either RelationalError SessionId)

409374createSessionAtCommit conn@(InProcessConnection _) commitId = do

410375 newSessionId <- nextRandom

411376 atomically $ createSessionAtCommit_ commitId newSessionId conn

412−createSessionAtCommit conn@(RemoteProcessConnection _) uuid = remoteCall conn (CreateSessionAtCommit uuid)

377+createSessionAtCommit conn@(RemoteConnection _) uuid = remoteCall conn (CreateSessionAtCommit uuid)

413378

414379createSessionAtCommit_ :: TransactionId -> SessionId -> Connection -> STM (Either RelationalError SessionId)

415380createSessionAtCommit_ commitId newSessionId (InProcessConnection conf) = do

@@ -419,14 +384,14 @@ createSessionAtCommit_ commitId newSessionId (InProcessConnection conf) = do

419384 case RE.transactionForId commitId graph of

420385 Left err -> pure (Left err)

421386 Right transaction -> do

422− let freshDiscon = DisconnectedTransaction commitId (Trans.schemas transaction) NoOperation

387+ let freshDiscon = DisconnectedTransaction commitId (Trans.schemas transaction) False

423388 keyDuplication <- StmMap.lookup newSessionId sessions

424389 case keyDuplication of

425390 Just _ -> pure $ Left (SessionIdInUseError newSessionId)

426391 Nothing -> do

427392 StmMap.insert (Session freshDiscon defaultSchemaName) newSessionId sessions

428393 pure $ Right newSessionId

429−createSessionAtCommit_ _ _ (RemoteProcessConnection _) = error "createSessionAtCommit_ called on remote connection"

394+createSessionAtCommit_ _ _ (RemoteConnection _) = error "createSessionAtCommit_ called on remote connection"

430395

431396-- | Call 'createSessionAtHead' with a transaction graph's head's name to create a new session pinned to that head. This function returns a 'SessionId' which can be used in other function calls to reference the point in the transaction graph.

432397createSessionAtHead :: Connection -> HeadName -> IO (Either RelationalError SessionId)

@@ -438,22 +403,18 @@ createSessionAtHead conn@(InProcessConnection conf) headn = do

438403 case transactionForHead headn graph of

439404 Nothing -> pure $ Left (NoSuchHeadNameError headn)

440405 Just trans -> createSessionAtCommit_ (transactionId trans) newSessionId conn

441−createSessionAtHead conn@(RemoteProcessConnection _) headn = remoteCall conn (CreateSessionAtHead headn)

442−

443−-- | Used internally for server connections to keep track of remote nodes for the purpose of sending notifications later.

444−addClientNode :: Connection -> ProcessId -> IO ()

445−addClientNode (RemoteProcessConnection _) _ = error "addClientNode called on remote connection"

446−addClientNode (InProcessConnection conf) newProcessId = atomically (StmSet.insert newProcessId (ipClientNodes conf))

406+createSessionAtHead conn@(RemoteConnection _) headn = remoteCall conn (CreateSessionAtHead headn)

447407

448408-- | Discards a session, eliminating any uncommitted changes present in the session.

449409closeSession :: SessionId -> Connection -> IO ()

450410closeSession sessionId (InProcessConnection conf) =

451411 atomically $ StmMap.delete sessionId (ipSessions conf)

452−closeSession sessionId conn@(RemoteProcessConnection _) = remoteCall conn (CloseSession sessionId)

412+closeSession sessionId conn@(RemoteConnection _) = remoteCall conn (CloseSession sessionId)

453413

454414-- | 'close' cleans up the database access connection and closes any relevant sockets.

455415close :: Connection -> IO ()

456416close (InProcessConnection conf) = do

417+ cancel (ipCallbackAsync conf)

457418 atomically $ do

458419 let sessions = ipSessions conf

459420#if MIN_VERSION_stm_containers(1,0,0)

@@ -462,22 +423,18 @@ close (InProcessConnection conf) = do

462423 StmMap.deleteAll sessions

463424#endif

464425 pure ()

465− closeLocalNode (ipLocalNode conf)

466− closeTransport (ipTransport conf)

467426 let mLocks = ipLocks conf

468427 case mLocks of

469428 Nothing -> pure ()

470429 Just (lockFileH, _) -> closeLockFile lockFileH

471430

472−close conn@(RemoteProcessConnection conf) = do

473− _ <- remoteCall conn Logout :: IO Bool

474− closeLocalNode (rLocalNode conf)

475− closeTransport (rTransport conf)

431+close (RemoteConnection (RemoteConnectionConf conn)) =

432+ RPC.close conn

476433

477434--used only by the server EntryPoints

478435closeRemote_ :: Connection -> IO ()

479436closeRemote_ (InProcessConnection _) = error "invalid call of closeRemote_ on InProcessConnection"

480−closeRemote_ (RemoteProcessConnection conf) = runProcess (rLocalNode conf) (reconnect (rProcessId conf))

437+closeRemote_ (RemoteConnection (RemoteConnectionConf conn)) = RPC.close conn

481438

482439 --we need to actually close the localNode's connection to the remote

483440--within the database server, we must catch and handle all exception lest they take down the database process- this handling might be different for other use-cases

@@ -488,35 +445,15 @@ excEither = handle handler

488445 where

489446 handler exc | Just (_ :: AsyncException) <- fromException exc = throwIO exc

490447 | otherwise = pure (Left (UnhandledExceptionError (show exc)))

491−

492−runProcessResult :: LocalNode -> Process a -> IO a

493−runProcessResult localNode proc = do

494− ret <- newEmptyMVar

495− runProcess localNode $ do

496− val <- proc

497− liftIO $ putMVar ret val

498− takeMVar ret

499−

500−safeLogin :: Login -> ProcessId -> Process Bool

501−safeLogin login procId = do

502− ret <- call procId login

503− case ret of

504− Left (_ :: ServerError) -> pure False

505− Right val -> pure val

506448

507−remoteCall :: (Binary a, Binary b, Typeable a, Typeable b) => Connection -> a -> IO b

449+

450+remoteCall :: (Serialise a, Serialise b) => Connection -> a -> IO b

508451remoteCall (InProcessConnection _ ) _ = error "remoteCall called on local connection"

509−remoteCall (RemoteProcessConnection conf) arg = runProcessResult localNode $ do

510− ret <- safeCall serverProcessId arg

511− case ret of

512− Left err -> error ("server died: " ++ show err)

513− Right ret' -> case ret' of

514− Left RequestTimeoutError -> liftIO (throwIO RequestTimeoutException)

515− Left (ProcessDiedError _) -> liftIO (throwIO RemoteProcessDiedException)

516− Right val -> pure val

517− where

518− localNode = rLocalNode conf

519− serverProcessId = rProcessId conf

452+remoteCall (RemoteConnection (RemoteConnectionConf rpcConn)) arg = do

453+ eRet <- RPC.call rpcConn arg

454+ case eRet of

455+ Left err -> convertRPCErrors err

456+ Right val -> pure val

520457

521458sessionForSessionId :: SessionId -> Sessions -> STM (Either RelationalError Session)

522459sessionForSessionId sessionId sessions =

@@ -551,7 +488,7 @@ currentSchemaName sessionId (InProcessConnection conf) = atomically $ do

551488 case eSession of

552489 Left err -> pure (Left err)

553490 Right session -> pure (Right (Sess.schemaName session))

554−currentSchemaName sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveCurrentSchemaName sessionId)

491+currentSchemaName sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveCurrentSchemaName sessionId)

555492

556493-- | Switch to the named isomorphic schema.

557494setCurrentSchemaName :: SessionId -> Connection -> SchemaName -> IO (Either RelationalError ())

@@ -563,7 +500,7 @@ setCurrentSchemaName sessionId (InProcessConnection conf) sname = atomically $ d

563500 Right session -> case Sess.setSchemaName sname session of

564501 Left err -> pure (Left err)

565502 Right newSession -> StmMap.insert newSession sessionId sessions >> pure (Right ())

566−setCurrentSchemaName sessionId conn@(RemoteProcessConnection _) sname = remoteCall conn (ExecuteSetCurrentSchema sessionId sname)

503+setCurrentSchemaName sessionId conn@(RemoteConnection _) sname = remoteCall conn (ExecuteSetCurrentSchema sessionId sname)

567504

568505-- | Execute a relational expression in the context of the session and connection. Relational expressions are queries and therefore cannot alter the database.

569506executeRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)

@@ -587,7 +524,7 @@ executeRelationalExpr sessionId (InProcessConnection conf) expr = excEither $ at

587524 Right rel -> pure (force (Right rel)) -- this is necessary so that any undefined/error exceptions are spit out here

588525 Left err -> pure (Left err)

589526

590−executeRelationalExpr sessionId conn@(RemoteProcessConnection _) relExpr = remoteCall conn (ExecuteRelationalExpr sessionId relExpr)

527+executeRelationalExpr sessionId conn@(RemoteConnection _) relExpr = remoteCall conn (ExecuteRelationalExpr sessionId relExpr)

591528

592529-- | Execute a database context expression in the context of the session and connection. Database expressions modify the current session's disconnected transaction but cannot modify the transaction graph.

593530executeDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError ())

@@ -614,14 +551,14 @@ executeDatabaseContextExpr sessionId (InProcessConnection conf) expr = excEither

614551 if not (RE.dbc_dirty newState) then --nothing dirtied, nothing to do

615552 pure (Right ())

616553 else do

617− let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas NoOperation

554+ let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas True

618555 context' = RE.dbc_context newState

619556 newSubschemas = Schema.processDatabaseContextExprSchemasUpdate (Sess.subschemas session) expr

620557 newSchemas = Schemas context' newSubschemas

621558 newSession = Session newDiscon (Sess.schemaName session)

622559 StmMap.insert newSession sessionId sessions

623560 pure (Right ())

624−executeDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr)

561+executeDatabaseContextExpr sessionId conn@(RemoteConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr)

625562

626563-- | Similar to a git rebase, 'autoMergeToHead' atomically creates a temporary branch and merges it to the latest commit of the branch referred to by the 'HeadName' and commits the merge. This is useful to reduce incidents of 'TransactionIsNotAHeadError's but at the risk of merge errors (thus making it similar to rebasing). Alternatively, as an optimization, if a simple commit is possible (meaning that the head has not changed), then a fast-forward commit takes place instead.

627564autoMergeToHead :: SessionId -> Connection -> MergeStrategy -> HeadName -> IO (Either RelationalError ())

@@ -650,7 +587,7 @@ autoMergeToHead sessionId (InProcessConnection conf) strat headName' = do

650587 Left err -> pure (Left err)

651588 Right ((discon', graph'), transactionIdsAdded) ->

652589 pure (Right (discon', graph', transactionIdsAdded))

653−autoMergeToHead sessionId conn@(RemoteProcessConnection _) strat headName' = remoteCall conn (ExecuteAutoMergeToHead sessionId strat headName')

590+autoMergeToHead sessionId conn@(RemoteConnection _) strat headName' = remoteCall conn (ExecuteAutoMergeToHead sessionId strat headName')

654591

655592-- | Execute a database context IO-monad-based expression for the given session and connection. `DatabaseContextIOExpr`s modify the DatabaseContext but cannot be purely implemented.

656593--this is almost completely identical to executeDatabaseContextExpr above

@@ -670,28 +607,14 @@ executeDatabaseContextIOExpr sessionId (InProcessConnection conf) expr = excEith

670607 case res of

671608 Left err -> pure (Left err)

672609 Right newState -> do

673− let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas NoOperation

610+ let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas False

674611 newSchemas = Schemas context' (Sess.subschemas session)

675612 newSession = Session newDiscon (Sess.schemaName session)

676613 context' = RE.dbc_context newState

677614 atomically $ StmMap.insert newSession sessionId sessions

678615 pure (Right ())

679−executeDatabaseContextIOExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextIOExpr sessionId dbExpr)

616+executeDatabaseContextIOExpr sessionId conn@(RemoteConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextIOExpr sessionId dbExpr)

680617

681−{-

682−executeGraphExprSTM_ :: TransactionId -> SessionId -> Session -> Sessions -> TransactionGraphOperator -> TransactionGraph -> TVar TransactionGraph -> STM (Either RelationalError (TransactionGraph, DisconnectedTransaction)

683−executeGraphExprSTM_ freshId sessionId session sessions graphExpr graph graphTVar= do

684− case evalGraphOp freshId (Sess.disconnectedTransaction session) graph graphExpr of

685− Left err -> do

686− when updateGraphOnError (writeTVar graphTVar graph)

687− pure $ Left err

688− Right (discon', graph') -> do

689− writeTVar graphTVar graph'

690− let newSession = Session discon' (Sess.schemaName session)

691− STMMap.insert newSession sessionId sessions

692− pure $ Right graph'

693−-}

694−

695618-- process notifications for commits

696619executeCommitExprSTM_

697620 :: TransactionGraph

@@ -732,78 +655,8 @@ executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do

732655 --if freshId appears in the graph, then we need to pass it on

733656 let transIds = [freshId | isRight (RE.transactionForId freshId graph')]

734657 pure (Right (discon', graph', transIds))

735−{-

736−executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do

737− let strat = ipPersistenceStrategy conf

738− clientNodes = ipClientNodes conf

739− sessions = ipSessions conf

740− graphTvar = ipTransactionGraph conf

741− mLockFileH = ipLocks conf

742− lockHandler body = case graphExpr of

743− Commit -> case mLockFileH of

744− Nothing -> body False

745− Just (lockFileH, lockMVar) -> let acquireLocks = do

746− lastWrittenDigest <- takeMVar lockMVar

747− lockFile lockFileH WriteLock

748− latestDigest <- readGraphTransactionIdDigest strat

749− pure (latestDigest /= lastWrittenDigest)

750−

751− releaseLocks _ = do

752− --still holding the lock- get the latest digest

753− gDigest <- readGraphTransactionIdDigest strat

754− unlockFile lockFileH

755− putMVar lockMVar gDigest

756− in bracket acquireLocks releaseLocks body

757− _ -> body False

758− freshId <- nextRandom

759− lockHandler $ \dbWrittenByOtherProcess -> do

760− --if the database file has been updated since we wrote it last, load it before trying to sync our version done- this can result in TransactionNotAHeadErrors

761− --read transaction data and compare to existing graph

762− --in the future, we can detect if updated transaction graph can be safely merged (such as with a transaction on a separate head) (rebase-able commits should force the user to rebase from the client to confirm that the action makes sense)

763− manip <- atomically $ do

764− eSession <- sessionForSessionId sessionId sessions

765− --handle graph update by other process

766− oldGraph <- readTVar graphTvar

767− case eSession of

768− Left err -> pure (Left err)

769− Right session -> do

770− let mScriptSession = ipScriptSession conf

771− dbdir = case strat of

772− MinimalPersistence x -> x

773− CrashSafePersistence x -> x

774− _ -> error "accessing dbdir on non-persisted connection"

775− eRefreshedGraph <- if dbWrittenByOtherProcess then

776− unsafeIOToSTM (transactionGraphLoad dbdir oldGraph mScriptSession)

777− else

778− pure (Right oldGraph)

779− case eRefreshedGraph of

780− Left err -> pure (Left (DatabaseLoadError err))

781− Right refreshedGraph -> do

782− --snip it

783− eGraph <- executeGraphExprSTM_ dbWrittenByOtherProcess freshId sessionId session sessions graphExpr refreshedGraph graphTvar

784− --snip it

785− case eGraph of

786− Left err -> pure (Left err)

787− Right newGraph -> do

788− --handle commit

789− if isCommit graphExpr then do

790− case transactionForId (Sess.parentId session) oldGraph of

791− Left err -> pure $ Left err

792− Right previousTrans -> do

793− (evaldNots, nodes) <- executeCommitExprSTM_ (Trans.concreteDatabaseContext previousTrans) (Sess.concreteDatabaseContext session) clientNodes

794− nodesToNotify <- toList (StmSet.stream nodes)

795− pure $ Right (evaldNots, nodesToNotify, newGraph)

796− else

797− pure $ Right (M.empty, [], newGraph)

798− case manip of

799− Left err -> return $ Just err

800− Right (notsToFire, nodesToNotify, newGraph) -> do

801− --update filesystem database, if necessary

802− processTransactionGraphPersistence strat newGraph

803− sendNotifications nodesToNotify (ipLocalNode conf) notsToFire

804− pure Nothing

805−-}

806−executeGraphExpr sessionId conn@(RemoteProcessConnection _) graphExpr = remoteCall conn (ExecuteGraphExpr sessionId graphExpr)

658+

659+executeGraphExpr sessionId conn@(RemoteConnection _) graphExpr = remoteCall conn (ExecuteGraphExpr sessionId graphExpr)

807660

808661-- | A trans-graph expression is a relational query executed against the entirety of a transaction graph.

809662executeTransGraphRelationalExpr :: SessionId -> Connection -> TransGraphRelationalExpr -> IO (Either RelationalError Relation)

@@ -811,10 +664,7 @@ executeTransGraphRelationalExpr _ (InProcessConnection conf) tgraphExpr = excEit

811664 let graphTvar = ipTransactionGraph conf

812665 graph <- readTVar graphTvar

813666 pure $ force $ optimizeAndEvalTransGraphRelationalExpr graph tgraphExpr

814−{- case runReader (RE.evalRelationalExpr relExpr) (RE.mkRelationalExprState DBC.empty) of

815− Left err -> pure (Left err)

816− Right rel -> pure (force (Right rel))-}

817−executeTransGraphRelationalExpr sessionId conn@(RemoteProcessConnection _) tgraphExpr = remoteCall conn (ExecuteTransGraphRelationalExpr sessionId tgraphExpr)

667+executeTransGraphRelationalExpr sessionId conn@(RemoteConnection _) tgraphExpr = remoteCall conn (ExecuteTransGraphRelationalExpr sessionId tgraphExpr)

818668

819669-- | Schema expressions manipulate the isomorphic schemas for the current 'DatabaseContext'.

820670executeSchemaExpr :: SessionId -> Connection -> Schema.SchemaExpr -> IO (Either RelationalError ())

@@ -834,26 +684,27 @@ executeSchemaExpr sessionId (InProcessConnection conf) schemaExpr = atomically $

834684 --hm- maybe we should start using lenses

835685 let discon = Sess.disconnectedTransaction session

836686 newSchemas = Schemas newContext newSubschemas

837− newSession = Session (DisconnectedTransaction (Discon.parentId discon) newSchemas NoOperation) (Sess.schemaName session)

687+ newSession = Session (DisconnectedTransaction (Discon.parentId discon) newSchemas False) (Sess.schemaName session)

838688 StmMap.insert newSession sessionId sessions

839689 pure (Right ())

840−executeSchemaExpr sessionId conn@(RemoteProcessConnection _) schemaExpr = remoteCall conn (ExecuteSchemaExpr sessionId schemaExpr)

690+executeSchemaExpr sessionId conn@(RemoteConnection _) schemaExpr = remoteCall conn (ExecuteSchemaExpr sessionId schemaExpr)

841691

842692-- | After modifying a 'DatabaseContext', 'commit' the transaction to the transaction graph at the head which the session is referencing. This will also trigger checks for any notifications which need to be propagated.

843693commit :: SessionId -> Connection -> IO (Either RelationalError ())

844694commit sessionId conn@(InProcessConnection _) = executeGraphExpr sessionId conn Commit

845−commit sessionId conn@(RemoteProcessConnection _) = remoteCall conn (ExecuteGraphExpr sessionId Commit)

846−

847−sendNotifications :: [ProcessId] -> LocalNode -> EvaluatedNotifications -> IO ()

848−sendNotifications pids localNode nots = mapM_ sendNots pids

849− where

850− sendNots remoteClientPid =

851− unless (M.null nots) $ runProcess localNode $ send remoteClientPid (NotificationMessage nots)

852−

695+commit sessionId conn@(RemoteConnection _) = remoteCall conn (ExecuteGraphExpr sessionId Commit)

696+

697+sendNotifications :: [ClientInfo] -> EvaluatedNotifications -> IO ()

698+sendNotifications clients notifs =

699+ unless (M.null notifs) $ forM_ clients sender

700+ where

701+ sender (RemoteClientInfo sock) = RPC.sendMessage sock (NotificationMessage notifs)

702+ sender (InProcessClientInfo tvar) = putMVar tvar notifs

703+

853704-- | Discard any changes made in the current 'Session' and 'DatabaseContext'. This resets the disconnected transaction to reference the original database context of the parent transaction and is a very cheap operation.

854705rollback :: SessionId -> Connection -> IO (Either RelationalError ())

855706rollback sessionId conn@(InProcessConnection _) = executeGraphExpr sessionId conn Rollback

856−rollback sessionId conn@(RemoteProcessConnection _) = remoteCall conn (ExecuteGraphExpr sessionId Rollback)

707+rollback sessionId conn@(RemoteConnection _) = remoteCall conn (ExecuteGraphExpr sessionId Rollback)

857708

858709-- | Write the transaction graph to disk. This function can be used to incrementally write new transactions to disk.

859710processTransactionGraphPersistence :: PersistenceStrategy -> [TransactionId] -> TransactionGraph -> IO ()

@@ -869,7 +720,7 @@ readGraphTransactionIdDigest (CrashSafePersistence dbdir) = readGraphTransaction

869720-- | Return a relation whose type would match that of the relational expression if it were executed. This is useful for checking types and validating a relational expression's types.

870721typeForRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)

871722typeForRelationalExpr sessionId conn@(InProcessConnection _) relExpr = atomically $ typeForRelationalExprSTM sessionId conn relExpr

872−typeForRelationalExpr sessionId conn@(RemoteProcessConnection _) relExpr = remoteCall conn (ExecuteTypeForRelationalExpr sessionId relExpr)

723+typeForRelationalExpr sessionId conn@(RemoteConnection _) relExpr = remoteCall conn (ExecuteTypeForRelationalExpr sessionId relExpr)

873724

874725typeForRelationalExprSTM :: SessionId -> Connection -> RelationalExpr -> STM (Either RelationalError Relation)

875726typeForRelationalExprSTM sessionId (InProcessConnection conf) relExpr = do

@@ -906,7 +757,7 @@ inclusionDependencies sessionId (InProcessConnection conf) = do

906757 else

907758 pure (Schema.inclusionDependenciesInSchema schema (B.inclusionDependencies context))

908759

909−inclusionDependencies sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveInclusionDependencies sessionId)

760+inclusionDependencies sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveInclusionDependencies sessionId)

910761

911762typeConstructorMapping :: SessionId -> Connection -> IO (Either RelationalError TypeConstructorMapping)

912763typeConstructorMapping sessionId (InProcessConnection conf) = do

@@ -917,7 +768,7 @@ typeConstructorMapping sessionId (InProcessConnection conf) = do

917768 Left err -> pure $ Left err

918769 Right (session, _) -> --warning, no schema support for typeconstructors

919770 pure (Right (B.typeConstructorMapping (Sess.concreteDatabaseContext session)))

920−typeConstructorMapping sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveTypeConstructorMapping sessionId)

771+typeConstructorMapping sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveTypeConstructorMapping sessionId)

921772

922773-- | Return an optimized database expression which is logically equivalent to the input database expression. This function can be used to determine which expression will actually be evaluated.

923774planForDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError GraphRefDatabaseContextExpr)

@@ -937,7 +788,7 @@ planForDatabaseContextExpr sessionId (InProcessConnection conf) dbExpr = do

937788 else -- don't show any optimization because the current optimization infrastructure relies on access to the base context- this probably underscores the need for each schema to have its own DatabaseContext, even if it is generated on-the-fly-}

938789 pure (Left NonConcreteSchemaPlanError)

939790

940−planForDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr)

791+planForDatabaseContextExpr sessionId conn@(RemoteConnection _) dbExpr = remoteCall conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr)

941792

942793-- | Return a relation which represents the current state of the global transaction graph. The attributes are

943794-- * current- boolean attribute representing whether or not the current session references this transaction

@@ -955,7 +806,7 @@ transactionGraphAsRelation sessionId (InProcessConnection conf) = do

955806 Right session ->

956807 graphAsRelation (Sess.disconnectedTransaction session) <$> readTVar tvar

957808

958−transactionGraphAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveTransactionGraph sessionId)

809+transactionGraphAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveTransactionGraph sessionId)

959810

960811-- | Returns the names and types of the relation variables in the current 'Session'.

961812relationVariablesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

@@ -977,7 +828,7 @@ relationVariablesAsRelation sessionId (InProcessConnection conf) = do

977828 let schemaContext = context {relationVariables = relvars }

978829 pure $ RE.relationVariablesAsRelation schemaContext graph

979830

980−relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId)

831+relationVariablesAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId)

981832

982833-- | Returns the names and types of the atom functions in the current 'Session'.

983834atomFunctionsAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

@@ -990,7 +841,7 @@ atomFunctionsAsRelation sessionId (InProcessConnection conf) = do

990841 Right (session, _) ->

991842 pure (AF.atomFunctionsAsRelation (atomFunctions (concreteDatabaseContext session)))

992843

993−atomFunctionsAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveAtomFunctionSummary sessionId)

844+atomFunctionsAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveAtomFunctionSummary sessionId)

994845

995846databaseContextFunctionsAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

996847databaseContextFunctionsAsRelation sessionId (InProcessConnection conf) = do

@@ -1002,7 +853,7 @@ databaseContextFunctionsAsRelation sessionId (InProcessConnection conf) = do

1002853 Right (session, _) ->

1003854 pure (DCF.databaseContextFunctionsAsRelation (dbcFunctions (concreteDatabaseContext session)))

1004855

1005−databaseContextFunctionsAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveDatabaseContextFunctionSummary sessionId)

856+databaseContextFunctionsAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveDatabaseContextFunctionSummary sessionId)

1006857

1007858-- | Returns the transaction id for the connection's disconnected transaction committed parent transaction.

1008859headTransactionId :: SessionId -> Connection -> IO (Either RelationalError TransactionId)

@@ -1013,7 +864,7 @@ headTransactionId sessionId (InProcessConnection conf) = do

1013864 case eSession of

1014865 Left err -> pure (Left err)

1015866 Right session -> pure $ Right (Sess.parentId session)

1016−headTransactionId sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveHeadTransactionId sessionId)

867+headTransactionId sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveHeadTransactionId sessionId)

1017868

1018869headNameSTM_ :: SessionId -> Sessions -> TVar TransactionGraph -> STM (Either RelationalError HeadName)

1019870headNameSTM_ sessionId sessions graphTvar = do

@@ -1033,7 +884,7 @@ headName sessionId (InProcessConnection conf) = do

1033884 let sessions = ipSessions conf

1034885 graphTvar = ipTransactionGraph conf

1035886 atomically (headNameSTM_ sessionId sessions graphTvar)

1036−headName sessionId conn@(RemoteProcessConnection _) = remoteCall conn (ExecuteHeadName sessionId)

887+headName sessionId conn@(RemoteConnection _) = remoteCall conn (ExecuteHeadName sessionId)

1037888

1038889-- | Returns a listing of all available atom types.

1039890atomTypesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

@@ -1047,7 +898,7 @@ atomTypesAsRelation sessionId (InProcessConnection conf) = do

1047898 case typesAsRelation (B.typeConstructorMapping (Sess.concreteDatabaseContext session)) of

1048899 Left err -> pure (Left err)

1049900 Right rel -> pure (Right rel)

1050−atomTypesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveAtomTypesAsRelation sessionId)

901+atomTypesAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveAtomTypesAsRelation sessionId)

1051902

1052903disconnectedTransactionIsDirty :: SessionId -> Connection -> IO (Either RelationalError Bool)

1053904disconnectedTransactionIsDirty sessionId (InProcessConnection conf) = do

@@ -1058,12 +909,12 @@ disconnectedTransactionIsDirty sessionId (InProcessConnection conf) = do

1058909 Left err -> pure (Left err)

1059910 Right session ->

1060911 pure (Right (isDirty session))

1061−disconnectedTransactionIsDirty sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveSessionIsDirty sessionId)

912+disconnectedTransactionIsDirty sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveSessionIsDirty sessionId)

1062913

1063914--used only for testing- we expect this to throw an exception

1064915callTestTimeout_ :: SessionId -> Connection -> IO Bool

1065916callTestTimeout_ _ (InProcessConnection _) = error "bad testing call"

1066−callTestTimeout_ sessionId conn@(RemoteProcessConnection _) = remoteCall conn (TestTimeout sessionId)

917+callTestTimeout_ sessionId conn@(RemoteConnection _) = remoteCall conn (TestTimeout sessionId)

1067918

1068919--used in tests only

1069920transactionGraph_ :: Connection -> IO TransactionGraph

@@ -1148,15 +999,8 @@ commitLock_ sessionId conf stmBlock = do

1148999 Right (notsToFire, nodesToNotify, newGraph, transactionIdsToPersist) -> do

11491000 --update filesystem database, if necessary

11501001 processTransactionGraphPersistence strat transactionIdsToPersist newGraph

1151− sendNotifications nodesToNotify (ipLocalNode conf) notsToFire

1002+ sendNotifications nodesToNotify notsToFire

11521003 pure (Right ())

1153−{-

1154−writeDisconAndGraph_ :: TVar TransactionGraph -> SessionId -> Session -> Sessions -> DisconnectedTransaction -> TransactionGraph -> STM ()

1155−writeDisconAndGraph_ graphTvar sessionId session sessions discon graph = do

1156− writeTVar graphTvar graph

1157− let newSession = Session discon (Sess.schemaName session)

1158− StmMap.insert newSession sessionId sessions

1159−-}

11601004

11611005-- | Runs an IO monad, commits the result when the monad returns no errors, otherwise, rolls back the changes and the error.

11621006withTransaction :: SessionId -> Connection -> IO (Either RelationalError a) -> IO (Either RelationalError ()) -> IO (Either RelationalError a)

@@ -1198,12 +1042,54 @@ executeDataFrameExpr sessionId conn@(InProcessConnection _) dfExpr = do

11981042 case verified of

11991043 Left err -> pure (Left err)

12001044 Right attrs -> do

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

1045+ let attrOrders = zipWith

1046+ (DF.AttributeOrder . attributeName)

1047+ attrs

1048+ orders

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

12031050 Left err -> pure (Left err)

12041051 Right dFrame -> do

12051052 let dFrame' = maybe dFrame (`DF.drop'` dFrame) (DF.offset dfExpr)

12061053 dFrame'' = maybe dFrame' (`DF.take'` dFrame') (DF.limit dfExpr)

12071054 pure (Right dFrame'')

1208−executeDataFrameExpr sessionId conn@(RemoteProcessConnection _) dfExpr = remoteCall conn (ExecuteDataFrameExpr sessionId dfExpr)

1055+executeDataFrameExpr sessionId conn@(RemoteConnection _) dfExpr = remoteCall conn (ExecuteDataFrameExpr sessionId dfExpr)

12091056

1057+validateMerkleHashes :: SessionId -> Connection -> IO (Either RelationalError ())

1058+validateMerkleHashes sessionId (InProcessConnection conf) = do

1059+ let sessions = ipSessions conf

1060+ atomically $ do

1061+ eSession <- sessionForSessionId sessionId sessions

1062+ case eSession of

1063+ Left err -> pure (Left err)

1064+ Right _ -> do

1065+ graph <- readTVar (ipTransactionGraph conf)

1066+ case Graph.validateMerkleHashes graph of

1067+ Left merkleErrs -> pure $ Left $ someErrors (map (\(MerkleValidationError tid expected actual) -> MerkleHashValidationError tid expected actual) merkleErrs)

1068+ Right () -> pure (Right ())

1069+validateMerkleHashes sessionId conn@RemoteConnection{} = remoteCall conn (ExecuteValidateMerkleHashes sessionId)

1070+

1071+type ClientNodes = StmSet.Set ClientInfo

1072+

1073+-- internal structure specific to in-process connections

1074+data InProcessConnectionConf = InProcessConnectionConf {

1075+ ipPersistenceStrategy :: PersistenceStrategy,

1076+ ipClientNodes :: ClientNodes,

1077+ ipSessions :: Sessions,

1078+ ipTransactionGraph :: TVar TransactionGraph,

1079+ ipScriptSession :: Maybe ScriptSession,

1080+ ipLocks :: Maybe (LockFile, MVar LockFileHash), -- nothing when NoPersistence

1081+ ipCallbackAsync :: Async ()

1082+ }

1083+

1084+-- clients may connect associate one socket/mvar with the server to register for change callbacks

1085+data ClientInfo = RemoteClientInfo (RPC.Locking Socket) |

1086+ InProcessClientInfo (MVar EvaluatedNotifications)

1087+

1088+instance Eq ClientInfo where

1089+ (RemoteClientInfo a) == (RemoteClientInfo b) = RPC.lockless a == RPC.lockless b

1090+ (InProcessClientInfo a) == (InProcessClientInfo b) = a == b

1091+ _ == _ = False

1092+

1093+instance Hashable ClientInfo where

1094+ hashWithSalt salt (RemoteClientInfo sock) = hashWithSalt salt (show (RPC.lockless sock))

1095+ hashWithSalt salt (InProcessClientInfo _) = hashWithSalt salt (1::Int)

src/lib/ProjectM36/DataFrame.hs+23−15

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

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

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

22{- A dataframe is a strongly-typed, ordered list of named tuples. A dataframe differs from a relation in that its tuples are ordered.-}

33module ProjectM36.DataFrame where

44import ProjectM36.Base

5−import ProjectM36.Attribute as A

5+import ProjectM36.Attribute as A hiding (drop)

66import ProjectM36.Error

77import qualified ProjectM36.Relation as R

88import ProjectM36.Relation.Show.Term

@@ -16,15 +16,19 @@ import qualified Data.List as L

1616import qualified Data.Set as S

1717import Data.Maybe

1818import qualified Data.Text as T

19−import Data.Binary

2019import Control.Arrow

21−#if __GLASGOW_HASKELL__ <= 802

20+#if __GLASGOW_HASKELL__ < 804

2221import Data.Monoid

2322#endif

2423

25−data AttributeOrderExpr = AttributeOrderExpr AttributeName Order deriving (Show, Generic, Binary)

26−data AttributeOrder = AttributeOrder AttributeName Order deriving (Show, Generic, Binary)

27−data Order = AscendingOrder | DescendingOrder deriving (Eq, Show, Generic, Binary)

24+data AttributeOrderExpr = AttributeOrderExpr AttributeName Order

25+ deriving (Show, Generic)

26+

27+data AttributeOrder = AttributeOrder AttributeName Order

28+ deriving (Show, Generic)

29+

30+data Order = AscendingOrder | DescendingOrder

31+ deriving (Eq, Show, Generic)

2832

2933ascending :: T.Text

3034ascending = "⬆"

@@ -39,9 +43,11 @@ data DataFrame = DataFrame {

3943 orders :: [AttributeOrder],

4044 attributes :: Attributes,

4145 tuples :: [DataFrameTuple]

42− } deriving (Show, Generic, Binary)

46+ }

47+ deriving (Show, Generic)

4348

44−data DataFrameTuple = DataFrameTuple Attributes (V.Vector Atom) deriving (Eq, Show, Generic, Binary)

49+data DataFrameTuple = DataFrameTuple Attributes (V.Vector Atom)

50+ deriving (Eq, Show, Generic)

4551

4652sortDataFrameBy :: [AttributeOrder] -> DataFrame -> Either RelationalError DataFrame

4753sortDataFrameBy attrOrders frame = do

@@ -75,7 +81,7 @@ compareTupleByOneAttributeName attr tuple1 tuple2 =

7581 Right atom2 -> compareAtoms atom1 atom2

7682

7783atomForAttributeName :: AttributeName -> DataFrameTuple -> Either RelationalError Atom

78−atomForAttributeName attrName (DataFrameTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) tupAttrs of

84+atomForAttributeName attrName (DataFrameTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) (attributesVec tupAttrs) of

7985 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))

8086 Just index -> case tupVec V.!? index of

8187 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))

@@ -122,17 +128,18 @@ data DataFrameExpr = DataFrameExpr {

122128 orderExprs :: [AttributeOrderExpr],

123129 offset :: Maybe Integer,

124130 limit :: Maybe Integer

125− } deriving (Show, Binary, Generic)

131+ }

132+ deriving (Show, Generic)

126133

127134dataFrameAsHTML :: DataFrame -> T.Text

128135-- web browsers don't display tables with empty cells or empty headers, so we have to insert some placeholders- it's not technically the same, but looks as expected in the browser

129136dataFrameAsHTML df

130− | length (tuples df) == 1 && L.null (attributes df) = style <>

137+ | length (tuples df) == 1 && A.null (attributes df) = style <>

131138 tablestart <>

132139 "<tr><th></th></tr>" <>

133140 "<tr><td></td></tr>" <>

134141 tablefooter <> "</table>"

135− | L.null (tuples df) && L.null (attributes df) = style <>

142+ | L.null (tuples df) && A.null (attributes df) = style <>

136143 tablestart <>

137144 "<tr><th></th></tr>" <>

138145 tablefooter <>

@@ -155,7 +162,7 @@ tuplesAsHTML = foldr folder ""

155162 folder tuple acc = acc <> tupleAsHTML tuple

156163

157164tupleAssocs :: DataFrameTuple -> [(AttributeName, Atom)]

158−tupleAssocs (DataFrameTuple attrVec tupVec) = V.toList $ V.map (first attributeName) (V.zip attrVec tupVec)

165+tupleAssocs (DataFrameTuple attrs tupVec) = V.toList $ V.map (first attributeName) (V.zip (attributesVec attrs) tupVec)

159166

160167

161168tupleAsHTML :: DataFrameTuple -> T.Text

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

163170 where

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

165172 atomAsHTML (RelationAtom rel) = RelHTML.relationAsHTML rel

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

166174 atomAsHTML atom = atomToText atom

167175

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

169−attributesAsHTML attrs orders' = "<tr>" <> T.concat (map oneAttrHTML (V.toList attrs)) <> "</tr>"

177+attributesAsHTML attrs orders' = "<tr>" <> T.concat (map oneAttrHTML (A.toList attrs)) <> "</tr>"

170178 where

171179 oneAttrHTML attr = "<th>" <> prettyAttribute attr <> ordering (attributeName attr) <> "</th>"

172180 ordering attrName = " " <> case L.find (\(AttributeOrder nam _) -> nam == attrName) orders' of

src/lib/ProjectM36/DataTypes/Interval.hs+2

@@ -37,6 +37,7 @@ supportsInterval typ = case typ of

3737 BoolAtomType -> False

3838 RelationAtomType _ -> False

3939 ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this

40+ RelationalExprAtomType -> False

4041 TypeVariableType _ -> False

4142

4243supportsOrdering :: AtomType -> Bool

@@ -50,6 +51,7 @@ supportsOrdering typ = case typ of

5051 ByteStringAtomType -> False

5152 BoolAtomType -> False

5253 RelationAtomType _ -> False

54+ RelationalExprAtomType -> False

5355 ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this

5456 TypeVariableType _ -> False

5557

src/lib/ProjectM36/DataTypes/Primitive.hs+1

@@ -42,3 +42,4 @@ atomTypeForAtom (ByteStringAtom _) = ByteStringAtomType

4242atomTypeForAtom (BoolAtom _) = BoolAtomType

4343atomTypeForAtom (RelationAtom (Relation attrs _)) = RelationAtomType attrs

4444atomTypeForAtom (ConstructedAtom _ aType _) = aType

45+atomTypeForAtom (RelationalExprAtom _) = RelationalExprAtomType

src/lib/ProjectM36/DataTypes/Sorting.hs+1

@@ -24,6 +24,7 @@ isSortableAtomType typ = case typ of

2424 DateTimeAtomType -> True

2525 ByteStringAtomType -> False

2626 BoolAtomType -> True

27+ RelationalExprAtomType -> False

2728 RelationAtomType _ -> False

2829 ConstructedAtomType _ _ -> False

2930 TypeVariableType _ -> False

src/lib/ProjectM36/DatabaseContext.hs+17−2

@@ -1,11 +1,15 @@

11module ProjectM36.DatabaseContext where

22import ProjectM36.Base

3+import Control.Monad (void)

34import qualified Data.Map as M

45import qualified Data.HashSet as HS

56import ProjectM36.DataTypes.Basic

67import ProjectM36.AtomFunctions.Basic

7−import ProjectM36.DatabaseContextFunction

88import ProjectM36.Relation

9+import qualified Data.ByteString.Lazy as BL

10+import ProjectM36.AtomFunction as AF

11+import ProjectM36.DatabaseContextFunction as DBCF

12+import Codec.Winery

913

1014empty :: DatabaseContext

1115empty = DatabaseContext { inclusionDependencies = M.empty,

@@ -17,7 +21,7 @@ empty = DatabaseContext { inclusionDependencies = M.empty,

1721

1822-- | Remove TransactionId markers on GraphRefRelationalExpr

1923stripGraphRefRelationalExpr :: GraphRefRelationalExpr -> RelationalExpr

20−stripGraphRefRelationalExpr = fmap (const ())

24+stripGraphRefRelationalExpr = void

2125

2226-- | convert an existing database context into its constituent expression.

2327databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseContextExpr

@@ -37,3 +41,14 @@ basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,

3741 notifications = M.empty,

3842 typeConstructorMapping = basicTypeConstructorMapping

3943 }

44+

45+--for building the Merkle hash

46+hashBytes :: DatabaseContext -> BL.ByteString

47+hashBytes ctx = BL.fromChunks [incDeps, rvs, nots, tConsMap] <> atomFs <> dbcFs

48+ where

49+ incDeps = serialise (inclusionDependencies ctx)

50+ rvs = serialise (relationVariables ctx)

51+ atomFs = HS.foldr (mappend . AF.hashBytes) mempty (atomFunctions ctx)

52+ dbcFs = HS.foldr (mappend . DBCF.hashBytes) mempty (dbcFunctions ctx)

53+ nots = serialise (notifications ctx)

54+ tConsMap = serialise (typeConstructorMapping ctx)

src/lib/ProjectM36/DatabaseContextFunction.hs+17−1

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

1+{-# LANGUAGE CPP #-}

12module ProjectM36.DatabaseContextFunction where

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

34import ProjectM36.Base

45import ProjectM36.Error

6+import ProjectM36.Serialise.Base ()

57import ProjectM36.Attribute as A

68import ProjectM36.Relation

79import ProjectM36.AtomType

@@ -9,6 +11,8 @@ import qualified Data.HashSet as HS

911import qualified Data.Map as M

1012import ProjectM36.ScriptSession

1113import qualified Data.Text as T

14+import qualified Data.ByteString.Lazy as BL

15+import Codec.Winery

1216

1317emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction

1418emptyDatabaseContextFunction name = DatabaseContextFunction {

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

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

6266

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

68+#ifdef PM36_HASKELL_SCRIPTING

6469loadDatabaseContextFunctions = loadFunction

70+#else

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

72+#endif

6573

6674databaseContextFunctionsAsRelation :: DatabaseContextFunctions -> Either RelationalError Relation

6775databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups

@@ -72,4 +80,12 @@ databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups

7280 dbcFuncToTuple func = [TextAtom (dbcFuncName func),

7381 TextAtom (dbcTextType (dbcFuncType func))]

7482 dbcTextType typ = T.intercalate " -> " (map prettyAtomType typ ++ ["DatabaseContext", "DatabaseContext"])

75−

83+

84+-- for merkle hash

85+hashBytes :: DatabaseContextFunction -> BL.ByteString

86+hashBytes func = BL.fromChunks [fname, ftype, fbody]

87+ where

88+ fname = serialise (dbcFuncName func)

89+ ftype = serialise (dbcFuncType func)

90+ fbody = case dbcFuncBody func of

91+ DatabaseContextFunctionBody mBody _ -> serialise mBody

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

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

11{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}

22module ProjectM36.DatabaseContextFunctionError where

33import GHC.Generics

4−import Data.Binary

54import Control.DeepSeq

76{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}

87data DatabaseContextFunctionError = DatabaseContextFunctionUserError String

9− deriving (Generic, Eq, Show, Binary, NFData)

8+ deriving (Generic, Eq, Show, NFData)

src/lib/ProjectM36/DisconnectedTransaction.hs+2−6

@@ -11,11 +11,7 @@ parentId :: DisconnectedTransaction -> TransactionId

1111parentId (DisconnectedTransaction pid _ _) = pid

1212

1313isDirty :: DisconnectedTransaction -> Bool

14−isDirty (DisconnectedTransaction _ _ NoOperation) = False

15−isDirty _ = True

16−

17−diffExpr :: DisconnectedTransaction -> DatabaseContextExpr

18−diffExpr (DisconnectedTransaction _ _ expr) = expr

14+isDirty (DisconnectedTransaction _ _ flag) = flag

1915

2016freshTransaction :: TransactionId -> Schemas -> DisconnectedTransaction

21−freshTransaction tid schemas' = DisconnectedTransaction tid schemas' NoOperation

17+freshTransaction tid schemas' = DisconnectedTransaction tid schemas' False

src/lib/ProjectM36/Error.hs+20−14

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

11{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}

22module ProjectM36.Error where

33import ProjectM36.Base

4+import ProjectM36.MerkleHash

45import ProjectM36.DatabaseContextFunctionError

56import ProjectM36.AtomFunctionError

67import qualified Data.Set as S

@@ -8,7 +9,6 @@ import Control.DeepSeq (NFData, rnf)

89import Control.DeepSeq.Generics (genericRnf)

910import GHC.Generics (Generic)

1011import qualified Data.Text as T

11−import Data.Binary

1212import Data.Typeable

1313import Control.Exception

1414

@@ -81,7 +81,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

8181 | RelationValuedAttributesNotSupportedError [AttributeName]

8282 | NotificationNameInUseError NotificationName

8383 | NotificationNameNotInUseError NotificationName

84− | ImportError T.Text -- really? This should be broken out into some other error type- this has nothing to do with relational algebra

84+ | ImportError ImportError'

8585 | ExportError T.Text

8686 | UnhandledExceptionError String

8787 | MergeTransactionError MergeError

@@ -100,14 +100,17 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

100100 | NonConcreteSchemaPlanError

101101

102102 | NoUncommittedContextInEvalError

103−

103+ | TupleExprsReferenceMultipleMarkersError

104+

105+ | MerkleHashValidationError TransactionId MerkleHash MerkleHash

106+

104107 | MultipleErrors [RelationalError]

105− deriving (Show,Eq,Generic,Binary,Typeable, NFData)

108+ deriving (Show,Eq,Generic,Typeable, NFData)

106109

107110data PersistenceError = InvalidDirectoryError FilePath |

108111 MissingTransactionError TransactionId |

109112 WrongDatabaseFormatVersionError String String

110− deriving (Show, Eq, Generic, Binary, NFData)

113+ deriving (Show, Eq, Generic, NFData)

111114

112115--collapse list of errors into normal error- if there is just one, just return one

113116someErrors :: [RelationalError] -> RelationalError

@@ -125,7 +128,7 @@ data MergeError = SelectedHeadMismatchMergeError |

125128 StrategyViolatesComponentMergeError | --failed merge in inc deps, relvars, etc.

126129 StrategyViolatesRelationVariableMergeError |

127130 StrategyViolatesTypeConstructorMergeError

128− deriving (Show, Eq, Generic, Binary, Typeable)

131+ deriving (Show, Eq, Generic, Typeable)

129132

130133instance NFData MergeError where rnf = genericRnf

131134

@@ -133,17 +136,20 @@ data ScriptCompilationError = TypeCheckCompilationError String String | --expect

133136 SyntaxErrorCompilationError String |

134137 ScriptCompilationDisabledError |

135138 OtherScriptCompilationError String

136− deriving (Show, Eq, Generic, Binary, Typeable, NFData)

139+ deriving (Show, Eq, Generic, Typeable, NFData)

137140

138141instance Exception ScriptCompilationError

139142

140143data SchemaError = RelVarReferencesMissing (S.Set RelVarName) |

141144 RelVarInReferencedMoreThanOnce RelVarName |

142145 RelVarOutReferencedMoreThanOnce RelVarName

143− deriving (Show, Eq, Generic, Binary, Typeable, NFData)

144−

145−

146−-- errors returned from the distributed-process call handlers

147−data ServerError = RequestTimeoutError |

148− ProcessDiedError String

149− deriving (Generic, Binary, Eq)

146+ deriving (Show, Eq, Generic, Typeable, NFData)

147+

148+

149+data ImportError' = InvalidSHA256Error T.Text

150+ | SHA256MismatchError T.Text T.Text

151+ | InvalidFileURIError T.Text

152+ | ImportFileDecodeError T.Text

153+ | ImportFileError T.Text

154+ | ImportDownloadError T.Text

155+ deriving (Show, Eq, Generic, Typeable, NFData)

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

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

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

1+{-# LANGUAGE CPP #-}

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

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

44module ProjectM36.FileLock where

src/lib/ProjectM36/GraphRefRelationalExpr.hs+24−25

@@ -1,41 +1,37 @@

11module ProjectM36.GraphRefRelationalExpr where

22--evaluate relational expressions across the entire transaction graph to support cross-transaction referencing

33import ProjectM36.Base

4−import ProjectM36.Error

54import qualified Data.Set as S

7−-- core evaluation function- all other relational expr forms compile to GraphRefRelationalExpr

8−eval :: GraphRefRelationalExpr -> TransactionGraph -> Either RelationalError Relation

9−eval = undefined

10−{-eval (MakeRelationFromExprs mAttrExprs tupleExprs) graph = do

11− mAttrs <- case mAttrExprs of

12− Just _ ->

13− Just . A.attributesFromList <$> mapM (evalAttrExpr tConss) (fromMaybe [] mAttrExprs)

14− Nothing -> pure Nothing

15− tuples <- mapM (evalTupleExpr mAttrs) tupleExprs

16− let attrs = fromMaybe firstTupleAttrs mAttrs

17− firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)

18− mkRelation attrs (RelationTupleSet tuples)

19−

20−

21−-}

6+--import Debug.Trace

227

238data SingularTransactionRef = SingularTransactionRef GraphRefTransactionMarker |

249 MultipleTransactionsRef |

2510 NoTransactionsRef

2611 deriving (Eq, Show)

12+

13+instance Semigroup SingularTransactionRef where

14+ NoTransactionsRef <> x = x

15+ MultipleTransactionsRef <> _ = MultipleTransactionsRef

16+ SingularTransactionRef tidA <> s@(SingularTransactionRef tidB) =

17+ if tidA == tidB then

18+ s

19+ else

20+ MultipleTransactionsRef

21+ s@SingularTransactionRef{} <> NoTransactionsRef = s

22+ _ <> MultipleTransactionsRef = MultipleTransactionsRef

23+

24+instance Monoid SingularTransactionRef where

25+ mempty = NoTransactionsRef

2726

2827-- | return `Just transid` if this GraphRefRelationalExpr refers to just one transaction in the graph. This is useful for determining if certain optimizations can apply.

29−singularTransaction :: GraphRefRelationalExpr -> SingularTransactionRef

30−singularTransaction expr =

31− if S.null transSet then

32− NoTransactionsRef

33− else if S.size transSet == 1 then

34− SingularTransactionRef (head (S.toList transSet))

35− else

36− MultipleTransactionsRef

28+singularTransaction :: Foldable t => t GraphRefTransactionMarker -> SingularTransactionRef

29+singularTransaction expr

30+ | S.null transSet = NoTransactionsRef

31+ | S.size transSet == 1 = SingularTransactionRef (head (S.toList transSet))

32+ | otherwise = MultipleTransactionsRef

3733 where

38− transSet = foldr (\transId acc -> S.insert transId acc) S.empty expr

34+ transSet = foldr S.insert S.empty expr

3935

4036-- | Return True if two 'GraphRefRelationalExpr's both refer exclusively to the same transaction (or none at all).

4137inSameTransaction :: GraphRefRelationalExpr -> GraphRefRelationalExpr -> Maybe GraphRefTransactionMarker

@@ -44,3 +40,6 @@ inSameTransaction exprA exprB = case (stA, stB) of

4440 _ -> Nothing

4541 where stA = singularTransaction exprA

4642 stB = singularTransaction exprB

43+

44+singularTransactions :: (Foldable f, Foldable t) => f (t GraphRefTransactionMarker) -> SingularTransactionRef

45+singularTransactions = foldMap singularTransaction

src/lib/ProjectM36/InclusionDependency.hs+5−6

@@ -4,17 +4,16 @@ import ProjectM36.Attribute

44import ProjectM36.Error

55import ProjectM36.Relation

66import qualified Data.Map as M

7−import qualified Data.Text as T

98inclusionDependenciesAsRelation :: InclusionDependencies -> Either RelationalError Relation

109inclusionDependenciesAsRelation incDeps =

1110 mkRelationFromList attrs (map incDepAsAtoms (M.toList incDeps))

1211 where

1312 attrs = attributesFromList [Attribute "name" TextAtomType,

14− Attribute "sub" TextAtomType,

15− Attribute "super" TextAtomType

13+ Attribute "sub" RelationalExprAtomType,

14+ Attribute "super" RelationalExprAtomType

1615 ]

1716 incDepAsAtoms (name, InclusionDependency exprA exprB) = [TextAtom name,

18− TextAtom (T.pack (show exprA)),

19− TextAtom (T.pack (show exprB))]

20−

17+ RelationalExprAtom exprA,

18+ RelationalExprAtom exprB]

19+

src/lib/ProjectM36/IsomorphicSchema.hs+3−6

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

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

1+{-# LANGUAGE DeriveGeneric, LambdaCase, DerivingVia #-}

22module ProjectM36.IsomorphicSchema where

33import ProjectM36.Base

44import ProjectM36.Error

@@ -9,14 +9,12 @@ import ProjectM36.RelationalExpression

99import qualified ProjectM36.AttributeNames as AN

1010import Control.Monad

1111import GHC.Generics

12−import Data.Binary

1312import qualified Data.Map as M

1413import qualified Data.Set as S

1514import qualified Data.List as L

16−#if __GLASGOW_HASKELL__ <= 802

15+#if __GLASGOW_HASKELL__ < 804

1716import Data.Monoid

1817#endif

19−

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

2119

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

@@ -29,8 +27,7 @@ import Data.Monoid

2927

3028data SchemaExpr = AddSubschema SchemaName SchemaIsomorphs |

3129 RemoveSubschema SchemaName

32− deriving (Generic, Binary, Show)

33−

30+ deriving (Generic, Show)

3431

3532isomorphs :: Schema -> SchemaIsomorphs

3633isomorphs (Schema i) = i

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

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

22import ProjectM36.Base

33import ProjectM36.Relation

44import qualified Data.Set as S

5−#if __GLASGOW_HASKELL__ <= 802

5+#if __GLASGOW_HASKELL__ < 804

66import Data.Monoid

77#endif

src/lib/ProjectM36/MerkleHash.hsnew file+9

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

1+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric, DerivingVia #-}

2+module ProjectM36.MerkleHash where

3+import Data.ByteString (ByteString)

4+import GHC.Generics

5+import Control.DeepSeq (NFData)

7+newtype MerkleHash = MerkleHash { _unMerkleHash :: ByteString }

8+ deriving (Show, Eq, Generic, Monoid, Semigroup, NFData)

src/lib/ProjectM36/NormalizeExpr.hs+7−2

@@ -21,7 +21,7 @@ processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = do

2121 mAttrs' <- case mAttrs of

2222 Nothing -> pure Nothing

2323 Just mAttrs'' -> Just <$> mapM processAttributeExpr mAttrs''

24− MakeRelationFromExprs mAttrs' <$> mapM processTupleExpr tupleExprs

24+ MakeRelationFromExprs mAttrs' <$> processTupleExprs tupleExprs

2525processRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)

2626processRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)

2727--requires current trans id and graph

@@ -115,8 +115,13 @@ processAtomExpr (FunctionAtomExpr fName atomExprs ()) =

115115processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr

116116processAtomExpr (ConstructedAtomExpr dConsName atomExprs ()) = ConstructedAtomExpr dConsName <$> mapM processAtomExpr atomExprs <*> askMarker

117117

118+processTupleExprs :: TupleExprs -> ProcessExprM GraphRefTupleExprs

119+processTupleExprs (TupleExprs () tupleExprs) = do

120+ marker <- askMarker

121+ TupleExprs marker <$> mapM processTupleExpr tupleExprs

122+

118123processTupleExpr :: TupleExpr -> ProcessExprM GraphRefTupleExpr

119−processTupleExpr (TupleExpr tMap) =

124+processTupleExpr (TupleExpr tMap) =

120125 TupleExpr . M.fromList <$> mapM (\(k,v) -> (,) k <$> processAtomExpr v) (M.toList tMap)

121126

122127--convert AttributeExpr to GraphRefAttributeExpr

src/lib/ProjectM36/Persist.hs+3−4

@@ -36,7 +36,6 @@ import Foreign.C

3636#endif

3737

3838import System.IO (withFile, IOMode(WriteMode), Handle)

39−import qualified Data.ByteString.Lazy as BS

4039import qualified Data.ByteString as BS'

4140import qualified Data.Text.Encoding as TE

4241

@@ -100,10 +99,10 @@ syncDirectory :: DiskSync -> FilePath -> IO ()

10099syncDirectory FsyncDiskSync path = directoryFsync path

101100syncDirectory NoDiskSync _ = pure ()

102101

103−writeBSFileSync :: DiskSync -> FilePath -> BS.ByteString -> IO ()

102+writeBSFileSync :: DiskSync -> FilePath -> BS'.ByteString -> IO ()

104103writeBSFileSync sync path bstring =

105104 withFile path WriteMode $ \handle -> do

106− BS.hPut handle bstring

105+ BS'.hPut handle bstring

107106 syncHandle sync handle

108107

109108directoryFsync :: FilePath -> IO ()

@@ -131,4 +130,4 @@ fdCount = do

131130 fds <- getDirectoryContents FDDIR

132131 pure ((length fds) - 2)

133132--not supported on non-linux

134−#endif

133+#endif

src/lib/ProjectM36/Relation.hs+17−22

@@ -9,7 +9,6 @@ import ProjectM36.Tuple

99import qualified ProjectM36.Attribute as A

1010import ProjectM36.TupleSet

1111import ProjectM36.Error

12−import ProjectM36.MiscUtils

1312--import qualified Control.Parallel.Strategies as P

1413import qualified ProjectM36.TypeConstructorDef as TCD

1514import qualified ProjectM36.DataConstructorDef as DCD

@@ -17,7 +16,6 @@ import qualified Data.Text as T

1716import Data.Either (isRight)

1817import System.Random.Shuffle

1918import Control.Monad.Random

20−import Data.List (sort)

2119

2220attributes :: Relation -> Attributes

2321attributes (Relation attrs _ ) = attrs

@@ -35,7 +33,7 @@ atomTypeForName :: AttributeName -> Relation -> Either RelationalError AtomType

3533atomTypeForName attrName (Relation attrs _) = A.atomTypeForAttributeName attrName attrs

3634

3735mkRelationFromList :: Attributes -> [[Atom]] -> Either RelationalError Relation

38−mkRelationFromList attrs atomMatrix =

36+mkRelationFromList attrs atomMatrix = do

3937 Relation attrs <$> mkTupleSetFromList attrs atomMatrix

4038

4139emptyRelationWithAttrs :: Attributes -> Relation

@@ -43,11 +41,6 @@ emptyRelationWithAttrs attrs = Relation attrs emptyTupleSet

4341

4442mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation

4543mkRelation attrs tupleSet =

46− --check that all attributes are unique- this cannot be done when creating attributes because the check can become expensive

47− let duplicateAttrNames = dupes (sort (map A.attributeName (V.toList attrs))) in

48− if not (null duplicateAttrNames) then

49− Left (DuplicateAttributeNamesError (S.fromList duplicateAttrNames))

50− else

5144 --check that all tuples have the same keys

5245 --check that all tuples have keys (1-N) where N is the attribute count

5346 case verifyTupleSet attrs tupleSet of

@@ -93,13 +86,12 @@ union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =

9386 else

9487 Right $ Relation attrs1 newtuples

9588 where

96− newtuples = RelationTupleSet $ HS.toList . HS.fromList $ asList tupSet1 ++ map (reorderTuple attrs1) (asList tupSet2)

97−

89+ newtuples = tupleSetUnion attrs1 tupSet1 tupSet2

90+

9891project :: S.Set AttributeName -> Relation -> Either RelationalError Relation

9992project attrNames rel@(Relation _ tupSet) = do

10093 newAttrs <- A.projectionAttributesForNames attrNames (attributes rel)

101− let newAttrNameSet = A.attributeNameSet newAttrs

102− newTupleList = map (tupleProject newAttrNameSet) (asList tupSet)

94+ newTupleList <- mapM (tupleProject newAttrs) (asList tupSet)

10395 pure (Relation newAttrs (RelationTupleSet (HS.toList (HS.fromList newTupleList))))

10496

10597rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation

@@ -154,7 +146,7 @@ group groupAttrNames newAttrName rel = do

154146 groupProjectionAttributes <- A.projectionAttributesForNames groupAttrNames (attributes rel)

155147 let groupAttr = Attribute newAttrName (RelationAtomType groupProjectionAttributes)

156148 matchingRelTuple tupIn = case imageRelationFor tupIn rel of

157− Right rel2 -> RelationTuple (V.singleton groupAttr) (V.singleton (RelationAtom rel2))

149+ Right rel2 -> RelationTuple (A.singleton groupAttr) (V.singleton (RelationAtom rel2))

158150 Left _ -> undefined

159151 mogrifier tupIn = pure (tupleExtend tupIn (matchingRelTuple tupIn))

160152 newAttrs = A.addAttribute groupAttr nonGroupProjectionAttributes

@@ -168,7 +160,8 @@ restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation

168160restrictEq tuple = restrict rfilter

169161 where

170162 rfilter :: RelationTuple -> Either RelationalError Bool

171− rfilter tupleIn = pure (tupleIntersection tuple tupleIn == tuple)

163+ rfilter tupleIn = do

164+ pure (tupleIntersection tuple tupleIn == tuple)

172165

173166-- unwrap relation-valued attribute

174167-- return error if relval attrs and nongroup attrs overlap

@@ -190,13 +183,13 @@ ungroup relvalAttrName rel = case attributesForRelval relvalAttrName rel of

190183tupleUngroup :: AttributeName -> Attributes -> RelationTuple -> Either RelationalError Relation

191184tupleUngroup relvalAttrName newAttrs tuple = do

192185 relvalRelation <- relationForAttributeName relvalAttrName tuple

186+ let nonGroupAttrs = A.intersection newAttrs (tupleAttributes tuple)

187+ nonGroupTupleProjection <- tupleProject nonGroupAttrs tuple

188+ let folder tupleIn acc = case acc of

189+ Left err -> Left err

190+ Right accRel ->

191+ union accRel $ Relation newAttrs (RelationTupleSet [tupleExtend nonGroupTupleProjection tupleIn])

193192 relFold folder (Right $ Relation newAttrs emptyTupleSet) relvalRelation

194− where

195− nonGroupTupleProjection = tupleProject nonGroupAttrNames tuple

196− nonGroupAttrNames = A.attributeNameSet newAttrs

197− folder tupleIn acc = case acc of

198− Left err -> Left err

199− Right accRel -> union accRel $ Relation newAttrs (RelationTupleSet [tupleExtend nonGroupTupleProjection tupleIn])

200193

201194attributesForRelval :: AttributeName -> Relation -> Either RelationalError Attributes

202195attributesForRelval relvalAttrName (Relation attrs _) = do

@@ -251,7 +244,8 @@ relMap mapper (Relation attrs tupleSet) =

251244

252245relMogrify :: (RelationTuple -> Either RelationalError RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation

253246relMogrify mapper newAttributes (Relation _ tupSet) = do

254− newTuples <- mapM mapper (asList tupSet)

247+ newTuples <- mapM (fmap (reorderTuple newAttributes) . mapper) (asList tupSet)

248+

255249 mkRelationFromTuples newAttributes newTuples

256250

257251relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a

@@ -297,7 +291,8 @@ typesAsRelation types = mkRelationFromTuples attrs tuples

297291 dConsType = RelationAtomType subAttrs

298292 tuples = map mkTypeConsDescription types

299293

300− mkTypeConsDescription (tCons, dConsList) = RelationTuple attrs (V.fromList [TextAtom (TCD.name tCons), mkDataConsRelation dConsList])

294+ mkTypeConsDescription (tCons, dConsList) =

295+ RelationTuple attrs (V.fromList [TextAtom (TCD.name tCons), mkDataConsRelation dConsList])

301296

302297 mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ TextAtom $ T.intercalate " " (DCD.name dCons:map (T.pack . show) (DCD.fields dCons)))) dConsList of

303298 Left err -> error ("mkRelationFromTuples pooped " ++ show err)

src/lib/ProjectM36/Relation/Parse/CSV.hs+7−3

@@ -38,8 +38,7 @@ csvAsRelation attrs tConsMap inString = case APBL.parse (csvWithHeader csvDecode

3838 let strHeader = V.map decodeUtf8 headerRaw

3939 strMapRecords = V.map convertMap vecMapsRaw

4040 convertMap hmap = HM.fromList $ L.map (decodeUtf8 *** (T.unpack . decodeUtf8)) (HM.toList hmap)

41− attrNames = V.map A.attributeName attrs

42− attrNameSet = S.fromList (V.toList attrNames)

41+ attrNameSet = A.attributeNameSet attrs

4342 headerSet = S.fromList (V.toList strHeader)

4443 parseAtom attrName aType textIn = case APT.parseOnly (parseCSVAtomP attrName tConsMap aType <* APT.endOfInput) textIn of

4544 Left err -> Left (ParseError (T.pack err))

@@ -47,7 +46,7 @@ csvAsRelation attrs tConsMap inString = case APBL.parse (csvWithHeader csvDecode

4746 makeTupleList :: HM.HashMap AttributeName String -> [Either CsvImportError Atom]

4847 makeTupleList tupMap = V.toList $ V.map (\attr ->

4948 either (Left . AttributeMappingError) Right $

50− parseAtom (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! A.attributeName attr)) attrs

49+ parseAtom (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! A.attributeName attr)) (attributesVec attrs)

5150 if attrNameSet == headerSet then do

5251 tupleList <- mapM sequence $ V.toList (V.map makeTupleList strMapRecords)

5352 case mkRelationFromList attrs tupleList of

@@ -83,6 +82,11 @@ parseCSVAtomP _ _ BoolAtomType = do

8382 case readMaybe bString of

8483 Nothing -> fail ("invalid BoolAtom string: " ++ bString)

8584 Just b -> pure (Right (BoolAtom b))

85+parseCSVAtomP _ _ RelationalExprAtomType = do

86+ reString <- T.unpack <$> takeToEndOfData

87+ case readMaybe reString of

88+ Nothing -> fail ("invalid RelationalExprAtom string: " ++ reString)

89+ Just b -> pure (Right (RelationalExprAtom b))

8690parseCSVAtomP attrName tConsMap typ@(ConstructedAtomType _ tvmap)

8791 | isIntervalAtomType typ = do

8892 begin <- (APT.char '[' >> pure False) <|> (APT.char '(' >> pure True)

src/lib/ProjectM36/Relation/Show/CSV.hs+5−5

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

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

22module ProjectM36.Relation.Show.CSV where

33import ProjectM36.Base

4−import ProjectM36.Attribute

4+import ProjectM36.Attribute as A

55import Data.Csv

66import ProjectM36.Tuple

77import qualified Data.ByteString.Lazy as BS

@@ -17,13 +17,13 @@ relationAsCSV (Relation attrs tupleSet)

1717 | relValAttrs /= [] =

1818 Left $ RelationValuedAttributesNotSupportedError (map attributeName relValAttrs)

1919 --check that there is at least one attribute

20− | V.null attrs =

20+ | A.null attrs =

2121 Left $ TupleAttributeCountMismatchError 0

2222 | otherwise =

2323 Right $ encodeByName bsAttrNames $ map RecordRelationTuple (asList tupleSet)

2424 where

25− relValAttrs = V.toList $ V.filter (isRelationAtomType . atomType) attrs

26− bsAttrNames = V.map (TE.encodeUtf8 . attributeName) attrs

25+ relValAttrs = V.toList $ V.filter (isRelationAtomType . atomType) (attributesVec attrs)

26+ bsAttrNames = V.map (TE.encodeUtf8 . attributeName) (attributesVec attrs)

2727

2828{-

2929instance ToRecord RelationTuple where

@@ -36,7 +36,7 @@ instance ToNamedRecord RecordRelationTuple where

3636 toNamedRecord rTuple = namedRecord $ map (\(k,v) -> TE.encodeUtf8 k .= RecordAtom v) (tupleAssocs $ unTuple rTuple)

3737

3838instance DefaultOrdered RecordRelationTuple where

39− headerOrder (RecordRelationTuple tuple) = V.map (TE.encodeUtf8 . attributeName) (tupleAttributes tuple)

39+ headerOrder (RecordRelationTuple tuple) = V.map (TE.encodeUtf8 . attributeName) (attributesVec (tupleAttributes tuple))

4040

4141newtype RecordAtom = RecordAtom {unAtom :: Atom}

4242

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

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

33import ProjectM36.Relation

44import ProjectM36.Tuple

55import ProjectM36.Atom

6+import ProjectM36.Attribute as A

67import ProjectM36.AtomType

78import qualified Data.List as L

89import Data.Text (Text, pack)

910import qualified Data.Text as T

1011import qualified Data.Text.IO as TIO

11−import qualified Data.Vector as V

12−#if __GLASGOW_HASKELL__ <= 802

12+#if __GLASGOW_HASKELL__ < 804

1313import Data.Monoid

1414#endif

1515

1616attributesAsHTML :: Attributes -> Text

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

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

1818 where

1919 oneAttrHTML attr = "<th>" <> prettyAttribute attr <> "</th>"

2020

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

5353 where

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

5555 atomAsHTML (RelationAtom rel) = relationAsHTML rel

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

5657 atomAsHTML atom = atomToText atom

5758

5859tupleSetAsHTML :: RelationTupleSet -> Text

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

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

99import qualified Data.List as L

1010import qualified Data.Text as T

1111import Control.Arrow hiding (left)

12−#if __GLASGOW_HASKELL__ <= 802

12+import Data.ByteString.Base64 as B64

13+import qualified Data.Text.Encoding as TE

14+#if __GLASGOW_HASKELL__ < 804

1315import Data.Monoid

1416#endif

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

@@ -97,6 +99,7 @@ showAtom :: Int -> Atom -> StringType

9799showAtom _ (RelationAtom rel) = renderTable $ relationAsTable rel

98100showAtom level (ConstructedAtom dConsName _ atoms) = showParens (level >= 1 && not (null atoms)) $ T.concat (L.intersperse " " (dConsName : map (showAtom 1) atoms))

99101showAtom _ (TextAtom t) = "\"" <> t <> "\""

102+showAtom _ (ByteStringAtom bs) = TE.decodeUtf8 (B64.encode bs)

100103showAtom _ atom = atomToText atom

101104

102105renderTable :: Table -> StringType

src/lib/ProjectM36/RelationalExpression.hs+289−369

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

11{-# LANGUAGE ScopedTypeVariables #-}

22{-# LANGUAGE FlexibleInstances #-}

33{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE OverloadedStrings #-}

45module ProjectM36.RelationalExpression where

56import ProjectM36.Relation

67import ProjectM36.Tuple

@@ -15,32 +16,38 @@ import ProjectM36.DataTypes.Primitive

1516import ProjectM36.AtomFunction

1617import ProjectM36.DatabaseContextFunction

1718import ProjectM36.Arbitrary

19+import ProjectM36.GraphRefRelationalExpr

1820import ProjectM36.Transaction

1921import qualified ProjectM36.Attribute as A

2022import qualified Data.Map as M

2123import qualified Data.HashSet as HS

2224import qualified Data.Set as S

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

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

25−import Control.Exception

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

26+import Data.Bifunctor (second)

2627import Data.Maybe

2728import Data.Either

2829import Data.Char (isUpper)

30+import Data.Time

31+import qualified Data.List.NonEmpty as NE

32+import Data.Functor.Identity

2933import qualified Data.Text as T

3034import qualified Data.Vector as V

3135import qualified ProjectM36.TypeConstructorDef as TCD

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

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

3238import Control.Monad.Except hiding (join)

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

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

3541import ProjectM36.NormalizeExpr

3642import ProjectM36.WithNameExpr

3743import Test.QuickCheck

44+import qualified Data.Functor.Foldable as Fold

45+import Control.Applicative

46+#ifdef PM36_HASKELL_SCRIPTING

3847import GHC hiding (getContext)

48+import Control.Exception

3949import GHC.Paths

40−import Data.Time.Clock

41−import Data.Time.Calendar

42−import qualified Data.List.NonEmpty as NE

43−import Data.Functor.Identity

50+#endif

4451

4552data DatabaseContextExprDetails = CountUpdatedTuples

4653

@@ -87,10 +94,10 @@ runRelationalExprM :: RelationalExprEnv -> RelationalExprM a -> Either Relationa

8794runRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))

8895

8996reGraph :: RelationalExprM TransactionGraph

90−reGraph = re_graph <$> R.ask

97+reGraph = asks re_graph

9198

9299reContext :: RelationalExprM DatabaseContext

93−reContext = re_context <$> R.ask

100+reContext = asks re_context

94101

95102mkRelationalExprEnv :: DatabaseContext -> TransactionGraph -> RelationalExprEnv

96103mkRelationalExprEnv ctx graph =

@@ -103,13 +110,13 @@ askEnv :: GraphRefRelationalExprM GraphRefRelationalExprEnv

103110askEnv = R.ask

104111

105112mergeTuplesIntoGraphRefRelationalExprEnv :: RelationTuple -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv

106−mergeTuplesIntoGraphRefRelationalExprEnv tupIn e =

107− e{ gre_extra = new_elems }

113+mergeTuplesIntoGraphRefRelationalExprEnv tupIn env =

114+ env { gre_extra = new_elems }

108115 where

109116 new_elems = Just (Left newTuple)

110− mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple e))

117+ mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple env))

111118 newTuple = mkRelationTupleFromMap mergedTupMap

112−

119+

113120mergeAttributesIntoGraphRefRelationalExprEnv :: Attributes -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv

114121mergeAttributesIntoGraphRefRelationalExprEnv attrsIn e = e { gre_extra = newattrs }

115122 where

@@ -135,12 +142,12 @@ data DatabaseContextEvalEnv = DatabaseContextEvalEnv

135142 }

136143

137144mkDatabaseContextEvalEnv :: TransactionId -> TransactionGraph -> DatabaseContextEvalEnv

138−mkDatabaseContextEvalEnv tid graph = DatabaseContextEvalEnv tid graph

145+mkDatabaseContextEvalEnv = DatabaseContextEvalEnv

139146

140147type DatabaseContextEvalMonad a = RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity) a

141148

142149runDatabaseContextEvalMonad :: DatabaseContext -> DatabaseContextEvalEnv -> DatabaseContextEvalMonad () -> Either RelationalError DatabaseContextEvalState

143−runDatabaseContextEvalMonad ctx env m = runIdentity (runExceptT (fst <$> (execRWST m env freshEnv)))

150+runDatabaseContextEvalMonad ctx env m = runIdentity (runExceptT (fst <$> execRWST m env freshEnv))

144151 where

145152 freshEnv = mkDatabaseContextEvalState ctx

146153

@@ -156,7 +163,7 @@ dbcRelationalExprEnv =

156163 mkRelationalExprEnv <$> getStateContext <*> dbcGraph

157164

158165getStateContext :: DatabaseContextEvalMonad DatabaseContext

159−getStateContext = dbc_context <$> get

166+getStateContext = gets dbc_context

160167

161168putStateContext :: DatabaseContext -> DatabaseContextEvalMonad ()

162169putStateContext ctx' = do

@@ -197,7 +204,7 @@ freshGraphRefRelationalExprEnv mctx graph = GraphRefRelationalExprEnv {

197204 }

198205

199206gfGraph :: GraphRefRelationalExprM TransactionGraph

200−gfGraph = gre_graph <$> R.ask

207+gfGraph = asks gre_graph

201208

202209envContext :: RelationalExprEnv -> DatabaseContext

203210envContext = re_context

@@ -205,174 +212,27 @@ envContext = re_context

205212setEnvContext :: RelationalExprEnv -> DatabaseContext -> RelationalExprEnv

206213setEnvContext e ctx = e { re_context = ctx }

207214

208−{-

209−--full evaluation down the graph

210−eval :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)

211−eval expr = do

212− env <- askEnv

213− eGfExpr <- processRelationalExpr expr

214− case eGfExpr of

215− Left err -> pure (Left err)

216− Right gfExpr -> pure $ evalGraphRefRelationalExpr gfExpr (re_graph env)

217−-}

218−{-

219−--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values

220−evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError GraphRefRelationalExpr)

221−evalRelationalExpr (RelationVariable name _) = do

222− relvarTable <- fmap (relationVariables . envContext) askEnv

223− return $ case M.lookup name relvarTable of

224− Just res -> Right res

225− Nothing -> Left $ RelVarNotDefinedError name

226−

227−evalRelationalExpr (Project attrNames expr) = do

228− eAttrNameSet <- evalAttributeNames attrNames expr

229− case eAttrNameSet of

230− Left err -> pure (Left err)

231− Right attrNameSet -> do

232− rel <- evalRelationalExpr expr

233− case rel of

234− Right rel2 -> pure $ Right (Project (AttributeNames attrNameSet) rel2)

235− Left err -> pure $ Left err

236−

237−evalRelationalExpr (Union exprA exprB) = do

238− relA <- evalRelationalExpr exprA

239− relB <- evalRelationalExpr exprB

240− case relA of

241− Left err -> return $ Left err

242− Right relA2 -> case relB of

243− Left err -> return $ Left err

244− Right relB2 -> return $ Right (Union relA2 relB2)

245−

246−evalRelationalExpr (Join exprA exprB) = do

247− relA <- evalRelationalExpr exprA

248− relB <- evalRelationalExpr exprB

249− case relA of

250− Left err -> return $ Left err

251− Right relA2 -> case relB of

252− Left err -> return $ Left err

253− Right relB2 -> return $ Right (Join relA2 relB2)

254−

255−evalRelationalExpr (Difference exprA exprB) = do

256− relA <- evalRelationalExpr exprA

257− relB <- evalRelationalExpr exprB

258− case relA of

259− Left err -> return $ Left err

260− Right relA2 -> case relB of

261− Left err -> return $ Left err

262− Right relB2 -> return $ Right (Difference relA2 relB2)

263−

264−evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) =

265− case mkRelation attributeSet tupleSet of

266− Right rel -> return $ Right (ExistingRelation rel)

267− Left err -> return $ Left err

268−

269−evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

270− currentContext <- fmap envContext askEnv

271− let tConss = typeConstructorMapping currentContext

272− -- 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

273− runExceptT $ do

274− mAttrs <- case mAttrExprs of

275− Just _ ->

276− Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)

277− Nothing -> pure Nothing

278− tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs

279− let attrs = fromMaybe firstTupleAttrs mAttrs

280− firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)

281− expr <- either throwE pure (mkRelation attrs (RelationTupleSet tuples))

282− pure (ExistingRelation expr)

283−

284−evalRelationalExpr (ExistingRelation rel) = pure (Right (ExistingRelation rel))

285−

286−evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do

287− evald <- evalRelationalExpr relExpr

288− case evald of

289− Right expr -> return $ Right (Rename oldAttrName newAttrName expr)

290− Left err -> return $ Left err

291−

292−evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do

293− eOldAttrNameSet <- evalAttributeNames oldAttrNames relExpr

294− case eOldAttrNameSet of

295− Left err -> pure (Left err)

296− Right oldAttrNameSet -> do

297− evald <- evalRelationalExpr relExpr

298− case evald of

299− Right expr -> return $ Right (Group (AttributeNames oldAttrNameSet) newAttrName expr)

300− Left err -> return $ Left err

301−

302−evalRelationalExpr (Ungroup attrName relExpr) = do

303− evald <- evalRelationalExpr relExpr

304− case evald of

305− Right expr -> return $ Right (Ungroup attrName expr)

306− Left err -> return $ Left err

307−

308−evalRelationalExpr (Restrict predicateExpr relExpr) = do

309− evald <- evalRelationalExpr relExpr

310− pred <- processRestrictionPredicateExpr predicateExpr

311− case evald of

312− Left err -> return $ Left err

313− Right expr ->

314− pure $ Right (Restrict pred expr)

315−

316−evalRelationalExpr (Equals relExprA relExprB) = do

317− evaldA <- evalRelationalExpr relExprA

318− evaldB <- evalRelationalExpr relExprB

319− case evaldA of

320− Left err -> return $ Left err

321− Right exprA -> case evaldB of

322− Left err -> return $ Left err

323− Right exprB -> return $ Right (Equals exprA exprB)

324−{-

325−evalRelationalExpr (With views mainExpr) = do

326− rstate <- ask

327−

328− let addScopedView ctx (vname,vexpr) = if vname `M.member` relationVariables ctx then

329− Left (RelVarAlreadyDefinedError vname)

330− else

331− case runState (evalDatabaseContextExpr (Assign vname vexpr)) (freshDatabaseState ctx) of

332− (Left err,_) -> Left err

333− (Right (), (ctx',_,_)) -> Right ctx'

334−

335− case foldM addScopedView (stateElemsContext rstate) views of

336− Left err -> return $ Left err

337− Right ctx'' -> do

338− let evalMainExpr expr = runReader (evalRelationalExpr expr) (RelationalExprEnv ctx'')

339− case evalMainExpr mainExpr of

340− Left err -> return $ Left err

341− Right rel -> return $ Right rel

342−-}

343−--warning: copy-pasta from above- refactor

344−evalRelationalExpr (NotEquals relExprA relExprB) = do

345− evaldA <- evalRelationalExpr relExprA

346− evaldB <- evalRelationalExpr relExprB

347− case evaldA of

348− Left err -> return $ Left err

349− Right exprA -> case evaldB of

350− Left err -> return $ Left err

351− Right exprB -> return $ Right (NotEquals exprA exprB)

352−

353−-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated

354−evalRelationalExpr (Extend tupleExpression relExpr) = do

355− eExpr <- evalRelationalExpr relExpr

356− case eExpr of

357− Left err -> pure (Left err)

358− Right expr -> do

359− tupProc <- processExtendTupleExpr tupleExpression

360− pure (Right (Extend tupProc expr))

361−-}

362215--helper function to process relation variable creation/assignment

363216setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()

364217setRelVar relVarName relExpr = do

365−

366218 currentContext <- getStateContext

367− --prevent recursive relvar definition

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

219+ --prevent recursive relvar definition by resolving references to relvars in previous states

220+ relExpr' <- resolve relExpr

221+ let newRelVars = M.insert relVarName relExpr' $ relationVariables currentContext

369222 potentialContext = currentContext { relationVariables = newRelVars }

370− --determine when to check constraints

371− graph <- dbcGraph

372− tid <- dbcTransId

373− case checkConstraints potentialContext tid graph of

374− Left err -> dbErr err

375− Right _ -> putStateContext potentialContext

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

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

225+ pure ()

226+ else do

227+ --determine when to check constraints

228+ graph <- dbcGraph

229+ tid <- dbcTransId

230+ case checkConstraints potentialContext tid graph of

231+ Left err -> dbErr err

232+ Right _ -> putStateContext potentialContext

233+

234+--fast-path insertion- we already know that the previous relvar validated correctly, so we can validate just the relation that is being inserted for attribute matches- without this, even a single tuple relation inserted causes the entire relation to be re-validated unnecessarily

235+--insertIntoRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()

376236

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

378238deleteRelVar :: RelVarName -> DatabaseContextEvalMonad ()

@@ -398,13 +258,10 @@ evalGraphRefDatabaseContextExpr (Define relVarName attrExprs) = do

398258 let eAttrs = runGraphRefRelationalExprM gfEnv (mapM evalGraphRefAttrExpr attrExprs)

399259 gfEnv = freshGraphRefRelationalExprEnv (Just context) graph

400260 case eAttrs of

401− Left err -> dbErr err

261+ Left err -> dbErr err

402262 Right attrsList -> do

403− let atomTypeErrs = lefts $ map ((`validateAtomType` tConss) . A.atomType) attrsList

404− if not (null atomTypeErrs) then

405− dbErr (someErrors atomTypeErrs)

406− else

407− case M.member relVarName relvars of

263+ lift $ except $ validateAttributes tConss (A.attributesFromList attrsList)

264+ case M.member relVarName relvars of

408265 True -> dbErr (RelVarAlreadyDefinedError relVarName)

409266 False -> setRelVar relVarName (ExistingRelation emptyRelation)

410267 where

@@ -417,13 +274,17 @@ evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do

417274 graph <- re_graph <$> dbcRelationalExprEnv

418275 context <- getStateContext

419276 let existingRelVar = M.lookup relVarName (relationVariables context)

277+ reEnv = freshGraphRefRelationalExprEnv (Just context) graph

278+ eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr)

420279 case existingRelVar of

421280 Nothing -> do

422− setRelVar relVarName expr

281+ case runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr) of

282+ Left err -> dbErr err

283+ Right reltype -> do

284+ lift $ except $ validateAttributes (typeConstructorMapping context) (attributes reltype)

285+ setRelVar relVarName expr

423286 Just existingRel -> do

424287 let eExpectedType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr existingRel)

425− eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr)

426− reEnv = freshGraphRefRelationalExprEnv (Just context) graph

427288 case eExpectedType of

428289 Left err -> dbErr err

429290 Right expectedType ->

@@ -431,33 +292,50 @@ evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do

431292 Left err -> dbErr err

432293 Right newExprType -> do

433294 if newExprType == expectedType then do

295+ lift $ except $ validateAttributes (typeConstructorMapping context) (attributes newExprType)

434296 setRelVar relVarName expr

435297 else

436298 dbErr (RelationTypeMismatchError (attributes expectedType) (attributes newExprType))

437299

438300evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do

439301 gfExpr <- relVarByName relVarName

440− evalGraphRefDatabaseContextExpr (Assign relVarName

441− (Union

442− gfExpr

443− relExpr))

302+ let optExpr = applyUnionCollapse (Union

303+ relExpr

304+ gfExpr)

305+ evalGraphRefDatabaseContextExpr (Assign relVarName optExpr)

444306

445307evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do

446308 gfExpr <- relVarByName relVarName

447− setRelVar relVarName (Restrict (NotPredicate predicate) gfExpr)

309+ let optExpr = applyRestrictionCollapse (Restrict (NotPredicate predicate) gfExpr)

310+ setRelVar relVarName optExpr

448311

449312--union of restricted+updated portion and the unrestricted+unupdated portion

450313evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do

451314 rvExpr <- relVarByName relVarName

315+ graph <- re_graph <$> dbcRelationalExprEnv

316+ context <- getStateContext

317+ let reEnv = freshGraphRefRelationalExprEnv (Just context) graph

318+ --get the current attributes name in the relvar to ensure that we don't conflict when renaming

319+ eExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr rvExpr)

320+ exprType' <- case eExprType of

321+ Left err -> throwError err

322+ Right t -> pure t

452323 let unrestrictedPortion = Restrict (NotPredicate pred') rvExpr

453− tmpAttr attr = "_tmp_" <> attr --this could certainly be improved to verify that there is no attribute name conflict

324+ tmpAttr = tmpAttrC 1

325+ tmpAttrC :: Int -> AttributeName -> AttributeName

326+ tmpAttrC c attr =

327+ let tmpAttrName = "_tmp_" <> T.pack (show c) <> attr in

328+ if tmpAttrName `S.member` A.attributeNameSet (attributes exprType') then

329+ tmpAttrC (c+1) attr

330+ else

331+ tmpAttrName

454332 updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)

455333 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)

456− --TODO restrictedPortion = Restrict pred'

334+ restrictedPortion = Restrict pred' rvExpr

457335 updated = foldr (\(oldname, atomExpr) accum ->

458336 let procAtomExpr = runProcessExprM UncommittedContextMarker (processAtomExpr atomExpr) in

459337 updateAttr oldname procAtomExpr accum

460− ) rvExpr (M.toList atomExprMap)

338+ ) restrictedPortion (M.toList atomExprMap)

461339 -- the atomExprMap could reference other attributes, so we must perform multi-pass folds

462340 updatedPortion = foldr projectAndRename updated (M.keys atomExprMap)

463341 setRelVar relVarName (Union unrestrictedPortion updatedPortion)

@@ -472,6 +350,8 @@ evalGraphRefDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do

472350 dbErr (InclusionDependencyNameInUseError newDepName)

473351 else do

474352 let potentialContext = currContext { inclusionDependencies = newDeps }

353+ -- if the potential context passes all constraints, then save it

354+ -- potential optimization: validate only the new constraint- all old constraints must already hold

475355 case checkConstraints potentialContext transId graph of

476356 Left err -> dbErr err

477357 Right _ ->

@@ -516,9 +396,9 @@ evalGraphRefDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do

516396 let oldTypes = typeConstructorMapping currentContext

517397 tConsName = TCD.name tConsDef

518398 -- validate that the constructor's types exist

519− case validateTypeConstructorDef tConsDef dConsDefList of

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

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

399+ case validateTypeConstructorDef tConsDef dConsDefList oldTypes of

400+ Left err -> throwError err

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

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

523403 | otherwise -> do

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

@@ -534,10 +414,9 @@ evalGraphRefDatabaseContextExpr (RemoveTypeConstructor tConsName) = do

534414 let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes

535415 putStateContext $ currentContext { typeConstructorMapping = newTypes }

536416

537−evalGraphRefDatabaseContextExpr (MultipleExpr exprs) = do

417+evalGraphRefDatabaseContextExpr (MultipleExpr exprs) =

538418 --the multiple expressions must pass the same context around- not the old unmodified context

539− ctx <- getContext

540− mapM_ (\expr -> evalGraphRefDatabaseContextExpr expr) exprs

419+ mapM_ evalGraphRefDatabaseContextExpr exprs

541420

542421evalGraphRefDatabaseContextExpr (RemoveAtomFunction funcName) = do

543422 currentContext <- getStateContext

@@ -567,7 +446,7 @@ evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArg

567446 context <- getStateContext

568447 graph <- dbcGraph

569448 --resolve atom arguments

570− let eAtomTypes = mapM (\atomExpr -> runGraphRefRelationalExprM gfEnv (typeForGraphRefAtomExpr emptyAttributes atomExpr)) atomArgExprs

449+ let eAtomTypes = mapM (runGraphRefRelationalExprM gfEnv . typeForGraphRefAtomExpr emptyAttributes) atomArgExprs

571450 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)

572451 gfEnv = freshGraphRefRelationalExprEnv (Just context) graph

573452 case eFunc of

@@ -582,11 +461,13 @@ evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArg

582461 case eAtomTypes of

583462 Left err -> dbErr err

584463 Right atomTypes -> do

585− let mValidTypes = map (\(expType, actType) -> case atomTypeVerify expType actType of

586− Left err -> Just err

587− Right _ -> Nothing) (zip (dbcFuncType func) atomTypes)

464+ let mValidTypes = zipWith (\ expType actType

465+ -> case atomTypeVerify expType actType of

466+ Left err -> Just err

467+ Right _ -> Nothing)

468+ (dbcFuncType func) atomTypes

588469 typeErrors = catMaybes mValidTypes

589− eAtomArgs = map (\arg -> runGraphRefRelationalExprM gfEnv (evalGraphRefAtomExpr emptyTuple arg)) atomArgExprs

470+ eAtomArgs = map (runGraphRefRelationalExprM gfEnv . evalGraphRefAtomExpr emptyTuple) atomArgExprs

590471 if length (lefts eAtomArgs) > 1 then

591472 dbErr (someErrors (lefts eAtomArgs))

592473 else if not (null typeErrors) then

@@ -595,7 +476,6 @@ evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArg

595476 case evalDatabaseContextFunction func (rights eAtomArgs) context of

596477 Left err -> dbErr err

597478 Right newContext -> putStateContext newContext

598−

599479data DatabaseContextIOEvalEnv = DatabaseContextIOEvalEnv

600480 { dbcio_transId :: TransactionId,

601481 dbcio_graph :: TransactionGraph,

@@ -631,10 +511,15 @@ getDBCIOContext = dbc_context <$> RWS.get

631511getDBCIORelationalExprEnv :: DatabaseContextIOEvalMonad RelationalExprEnv

632512getDBCIORelationalExprEnv = do

633513 context <- getDBCIOContext

634− env <- RWS.ask

635− pure $ mkRelationalExprEnv context (dbcio_graph env)

514+ mkRelationalExprEnv context . dbcio_graph <$> RWS.ask

636515

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

517+#if !defined(PM36_HASKELL_SCRIPTING)

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

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

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

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

522+#else

638523evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName funcType script) = do

639524 eScriptSession <- requireScriptSession

640525 currentContext <- getDBCIOContext

@@ -668,7 +553,6 @@ evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName funcType script) = d

668553 Right eContext -> case eContext of

669554 Left err -> pure (Left err)

670555 Right context' -> putDBCIOContext context'

671−

672556evalGraphRefDatabaseContextIOExpr (AddDatabaseContextFunction funcName funcType script) = do

673557 eScriptSession <- requireScriptSession

674558 currentContext <- getDBCIOContext

@@ -710,7 +594,6 @@ evalGraphRefDatabaseContextIOExpr (AddDatabaseContextFunction funcName funcType

710594 Right eContext -> case eContext of

711595 Left err -> pure (Left err)

712596 Right context' -> putDBCIOContext context'

713−

714597evalGraphRefDatabaseContextIOExpr (LoadAtomFunctions modName funcName modPath) = do

715598 currentContext <- getDBCIOContext

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

@@ -727,7 +610,7 @@ evalGraphRefDatabaseContextIOExpr (LoadDatabaseContextFunctions modName funcName

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

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

729612 in putDBCIOContext newContext

730−

613+#endif

731614evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs range) = do

732615 --Define

733616 currentContext <- getDBCIOContext

@@ -759,28 +642,20 @@ evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs

759642 Left err -> pure (Left err)

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

761644

762−{-

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

764−updateTupleWithAtomExprs exprMap context graph tupIn = do

765− --resolve all atom exprs

766− let

767− atomsAssoc <- mapM (\(attrName, atomExpr) -> do

768− let atom = unimplemented

769− --atom <- runReader (evalAtomExpr tupIn atomExpr) (mkRelationalExprState context graph)

770− pure (attrName, atom)

771− ) (M.toList exprMap)

772− pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)

773−-}

774645--run verification on all constraints

775646checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()

776−checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

647+checkConstraints context transId graph@(TransactionGraph graphHeads transSet) = do

777648 mapM_ (uncurry checkIncDep) (M.toList deps)

778649 where

779650 potentialGraph = TransactionGraph graphHeads (S.insert tempTrans transSet)

780651 tempStamp = UTCTime { utctDay = fromGregorian 2000 1 1,

781652 utctDayTime = secondsToDiffTime 0 }

782653 tempSchemas = Schemas context M.empty

783− tempTrans = Transaction U.nil (TransactionInfo (transId NE.:| []) tempStamp) tempSchemas

654+ tempTrans = Transaction U.nil tempTransInfo tempSchemas

655+ tempTransInfo = TransactionInfo { parents = transId NE.:| [],

656+ stamp = tempStamp,

657+ merkleHash = mempty

658+ }

784659

785660 deps = inclusionDependencies context

786661 -- no optimization available here, really? perhaps the optimizer should be passed down to here or the eval function should be passed through the environment

@@ -816,16 +691,7 @@ typeForRelationalExpr expr = do

816691 let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr)

817692 gfEnv = freshGraphRefRelationalExprEnv (Just context) graph

818693 runGf = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

819− lift $ except $ runGf

820−

821−--returns a database context with all tuples removed

822−--this is useful for type checking and optimization

823−{-

824−contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext

825−contextWithEmptyTupleSets contextIn = contextIn { relationVariables = relVars }

826− where

827− relVars = M.map (\rel -> ExistingRelation (Relation (attributes rel) emptyTupleSet)) (relationVariables contextIn)

828−-}

694+ lift $ except runGf

829695

830696liftE :: (Monad m) => m (Either a b) -> ExceptT a m b

831697liftE v = do

@@ -874,7 +740,7 @@ predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do

874740

875741predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do

876742 env <- askEnv

877− let attrs' = envAttributes env

743+ let attrs' = A.union attrs (envAttributes env)

878744 ctxtup' = envTuple env

879745 atomExprType <- typeForGraphRefAtomExpr attrs' atomExpr

880746 attr <- lift $ except $ case A.attributeForName attrName attrs of

@@ -918,7 +784,7 @@ tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName r

918784 Right rel

919785

920786extendGraphRefTupleExpressionProcessor :: Relation -> GraphRefExtendTupleExpr -> GraphRefRelationalExprM (Attributes, RelationTuple -> Either RelationalError RelationTuple)

921−extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do

787+extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) =

922788-- renv <- askEnv

923789 -- check that the attribute name is not in use

924790 case tupleExprCheckNewAttrName newAttrName relIn of

@@ -960,7 +826,7 @@ evalGraphRefAtomExpr tupIn (FunctionAtomExpr funcName arguments tid) = do

960826 throwError (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)

961827 else do

962828 let zippedArgs = zip (safeInit (atomFuncType func)) argTypes

963− mapM_ (\(expType, actType) -> do

829+ mapM_ (\(expType, actType) ->

964830 lift $ except (atomTypeVerify expType actType)) zippedArgs

965831 evaldArgs <- mapM (evalGraphRefAtomExpr tupIn) arguments

966832 case evalAtomFunction func evaldArgs of

@@ -982,58 +848,6 @@ evalGraphRefAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs _) = do

982848 mapM (evalGraphRefAtomExpr tupIn) dConsArgs

983849 pure (ConstructedAtom dConsName aType argAtoms)

984850

985−{-

986−evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprM Atom

987−evalAtomExpr tupIn expr =

988− -}

989−{-

990−

991−evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of

992− Right atom -> pure (Right atom)

993− err@(Left (NoSuchAttributeNamesError _)) -> do

994− rstate <- ask

995− let stateTup = stateTuple rstate

996− pure (atomForAttributeName attrName stateTup)

997− Left err -> pure (Left err)

998−evalAtomExpr _ (NakedAtomExpr atom) = pure (Right atom)

999−evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do

1000− argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn)) arguments

1001− context <- fmap stateElemsContext ask

1002− runExceptT $ do

1003− let functions = atomFunctions context

1004− func <- either throwE pure (atomFunctionForName funcName functions)

1005− let expectedArgCount = length (atomFuncType func) - 1

1006− actualArgCount = length argTypes

1007− safeInit [] = [] -- different behavior from normal init

1008− safeInit xs = init xs

1009− if expectedArgCount /= actualArgCount then

1010− throwE (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)

1011− else do

1012− let zippedArgs = zip (safeInit (atomFuncType func)) argTypes

1013− mapM_ (\(expType, eActType) -> do

1014− actType <- either throwE pure eActType

1015− either throwE pure (atomTypeVerify expType actType)) zippedArgs

1016− evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments

1017− case evalAtomFunction func evaldArgs of

1018− Left err -> throwE (AtomFunctionUserError err)

1019− Right result -> do

1020− --validate that the result matches the expected type

1021− _ <- either throwE pure (atomTypeVerify (last (atomFuncType func)) (atomTypeForAtom result))

1022− pure result

1023−evalAtomExpr tupIn (RelationAtomExpr relExpr) = do

1024− --merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes

1025− rstate <- ask

1026− runExceptT $ do

1027− let newState = mergeTuplesIntoRelationalExprState tupIn rstate

1028− relAtom <- either throwE pure (runReader (evalRelationalExpr relExpr) newState)

1029− pure (RelationAtom relAtom)

1030−evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExceptT $ do

1031− rstate <- lift ask

1032− let newState = mergeTuplesIntoRelationalExprState tupIn rstate

1033− aType <- either throwE pure (runReader (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)

1034− argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs

1035− pure (ConstructedAtom dConsName aType argAtoms)

1036−-}

1037851typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType

1038852typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do

1039853 renv <- askEnv

@@ -1046,7 +860,8 @@ typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do

1046860 Right attr -> pure (A.atomType attr)

1047861 Left _ -> case atomForAttributeName attrName envTup of

1048862 Right atom -> pure (atomTypeForAtom atom)

1049− Left _ -> throwError err

863+ Left _ -> --throwError (traceStack (show ("typeForGRAtomExpr", attrs, envTup)) err)

864+ throwError err

1050865 Left err -> throwError err

1051866

1052867typeForGraphRefAtomExpr _ (NakedAtomExpr atom) = pure (atomTypeForAtom atom)

@@ -1099,7 +914,7 @@ verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs tid) e

1099914 let handler :: RelationalError -> GraphRefRelationalExprM AtomType

1100915 handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName argCount expSubType actSubType)

1101916 handler err = throwError err

1102− verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler

917+ verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler

1103918 funcArgTypes <- mapM funcArgVerifier $ zip3 funcArgExprs expectedArgTypes [1..]

1104919 if length funcArgTypes /= length expectedArgTypes - 1 then

1105920 throwError (AtomTypeCountError funcArgTypes expectedArgTypes)

@@ -1123,7 +938,55 @@ evalGraphRefAttrExpr (AttributeAndTypeNameExpr attrName tCons transId) = do

1123938 pure $ Attribute attrName aType

1124939

1125940evalGraphRefAttrExpr (NakedAttributeExpr attr) = pure attr

1126−

941+

942+-- for tuple type concrete resolution (Nothing ==> Maybe Int) when the attributes hint is Nothing, we need to first process all the tuples, then extract the concrete types on a per-attribute basis, then reprocess the tuples to include the concrete types

943+evalGraphRefTupleExprs :: Maybe Attributes -> GraphRefTupleExprs -> GraphRefRelationalExprM [RelationTuple]

944+evalGraphRefTupleExprs _ (TupleExprs _ []) = pure []

945+evalGraphRefTupleExprs mAttrs (TupleExprs fixedMarker tupleExprL) = do

946+ tuples <- mapM (evalGraphRefTupleExpr mAttrs) tupleExprL

947+ finalAttrs <- case mAttrs of

948+ Just attrs -> pure attrs

949+ Nothing ->

950+ case tuples of

951+ [] -> pure emptyAttributes

952+ (headTuple:tailTuples) -> do

953+ --gather up resolved atom types or throw an error if an attribute cannot be made concrete from the inferred types- this could still fail if the type cannot be inferred (e.g. from [Nothing, Nothing])

954+ let

955+ processTupleAttrs (tupAttr, accAttr) =

956+ --if the attribute is a constructedatomtype, we can recurse into it to potentially resolve type variables

957+ if isResolvedAttribute accAttr && tupAttr == accAttr then

958+ pure accAttr

959+ else

960+ lift $ except $ resolveAttributes accAttr tupAttr

961+ mostResolvedTypes <-

962+ foldM (\acc tup -> do

963+ let zipped = zip (V.toList . attributesVec $ tupleAttributes tup) acc

964+ accNames = S.fromList $ map A.attributeName acc

965+ tupNames = A.attributeNameSet (tupleAttributes tup)

966+ attrNamesDiff = S.union (S.difference accNames tupNames) (S.difference tupNames accNames)

967+ unless (null attrNamesDiff) (throwError (AttributeNamesMismatchError attrNamesDiff))

968+ nextTupleAttrs <- mapM processTupleAttrs zipped

969+ let diff = A.attributesDifference (A.attributesFromList nextTupleAttrs) (A.attributesFromList acc)

970+ if diff == A.emptyAttributes then

971+ pure nextTupleAttrs

972+ else

973+ throwError (TupleAttributeTypeMismatchError diff)

974+ ) (V.toList . attributesVec $ tupleAttributes headTuple) tailTuples

975+ pure (A.attributesFromList mostResolvedTypes)

976+ --strategy: if all the tuple expr transaction markers refer to one location, then we can pass the type constructor mapping from that location, otherwise, we cannot assume that the types are the same

977+ tConsMap <- case singularTransactions tupleExprL of

978+ SingularTransactionRef commonTransId ->

979+ typeConstructorMapping <$> gfDatabaseContextForMarker commonTransId

980+ NoTransactionsRef ->

981+ typeConstructorMapping <$> gfDatabaseContextForMarker fixedMarker

982+ -- if there are multiple transaction markers in the TupleExprs, then we can't assume a single type constructor mapping- this could be improved in the future, but if all the tuples are fully resolved, then we don't need further resolution

983+ _ -> throwError TupleExprsReferenceMultipleMarkersError

984+ lift $ except $ validateAttributes tConsMap finalAttrs

985+ mapM (lift . except . resolveTypesInTuple finalAttrs tConsMap) tuples

986+

987+

988+--resolveAttributes (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",IntegerAtomType),("b",TypeVariableType "b")]))) (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",TypeVariableType "a"),("b",TextAtomType)])))

989+

1127990evalGraphRefTupleExpr :: Maybe Attributes -> GraphRefTupleExpr -> GraphRefRelationalExprM RelationTuple

1128991evalGraphRefTupleExpr mAttrs (TupleExpr tupMap) = do

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

@@ -1148,62 +1011,12 @@ evalGraphRefTupleExpr mAttrs (TupleExpr tupMap) = do

11481011 --verify that the attributes match

11491012 when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwError (TupleAttributeTypeMismatchError tupAttrs)

11501013 --we can't resolve types here- they have to be resolved at the atom level where the graph ref is held

1151−-- tup' <- lift $ except (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup))

1014+ --tup' <- lift $ except (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup))

11521015 let tup' = reorderTuple finalAttrs tup

11531016 --TODO: restore type resolution

11541017-- _ <- lift $ except (validateTuple tup' tConss)

11551018 pure tup'

11561019

1157−{-

1158−evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprM (Either RelationalError (S.Set AttributeName))

1159−evalAttributeNames attrNames expr = do

1160− eExprType <- typeForRelationalExpr expr

1161− case eExprType of

1162− Left err -> throwError err

1163− Right exprTyp -> do

1164− let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))

1165− case attrNames of

1166− AttributeNames names ->

1167− case A.projectionAttributesForNames names (attributes exprTyp) of

1168− Left err -> pure (Left err)

1169− Right attrs -> pure (Right (S.fromList (V.toList (A.attributeNames attrs))))

1170−

1171− InvertedAttributeNames names -> do

1172− let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet

1173− if not (S.null nonExistentAttributeNames) then

1174− pure (Left (AttributeNamesMismatchError nonExistentAttributeNames))

1175− else

1176− pure (Right (A.nonMatchingAttributeNameSet names typeNameSet))

1177−

1178− UnionAttributeNames namesA namesB -> do

1179− eNameSetA <- evalAttributeNames namesA expr

1180− case eNameSetA of

1181− Left err -> pure (Left err)

1182− Right nameSetA -> do

1183− eNameSetB <- evalAttributeNames namesB expr

1184− case eNameSetB of

1185− Left err -> pure (Left err)

1186− Right nameSetB ->

1187− pure (Right (S.union nameSetA nameSetB))

1188−

1189− IntersectAttributeNames namesA namesB -> do

1190− eNameSetA <- evalAttributeNames namesA expr

1191− case eNameSetA of

1192− Left err -> pure (Left err)

1193− Right nameSetA -> do

1194− eNameSetB <- evalAttributeNames namesB expr

1195− case eNameSetB of

1196− Left err -> pure (Left err)

1197− Right nameSetB ->

1198− pure (Right (S.intersection nameSetA nameSetB))

1199−

1200− RelationalExprAttributeNames attrExpr -> do

1201− eAttrExprType <- typeForRelationalExpr attrExpr

1202− case eAttrExprType of

1203− Left err -> pure (Left err)

1204− Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))

1205−-}

1206−

12071020--temporary implementation until we have a proper planner+executor

12081021evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation

12091022evalGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

@@ -1211,7 +1024,7 @@ evalGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

12111024 Just _ ->

12121025 Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)

12131026 Nothing -> pure Nothing

1214− tuples <- mapM (evalGraphRefTupleExpr mAttrs) tupleExprs

1027+ tuples <- evalGraphRefTupleExprs mAttrs tupleExprs

12151028 let attrs = fromMaybe firstTupleAttrs mAttrs

12161029 firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)

12171030 lift $ except $ mkRelation attrs (RelationTupleSet tuples)

@@ -1265,7 +1078,7 @@ evalGraphRefRelationalExpr (Extend extendTupleExpr expr) = do

12651078 rel <- evalGraphRefRelationalExpr expr

12661079 (newAttrs, tupProc) <- extendGraphRefTupleExpressionProcessor rel extendTupleExpr

12671080 lift $ except $ relMogrify tupProc newAttrs rel

1268−evalGraphRefRelationalExpr expr@With{} = do

1081+evalGraphRefRelationalExpr expr@With{} =

12691082 --strategy A: add relation variables to the contexts in the graph

12701083 --strategy B: drop in macros in place (easier programmatically)

12711084 --strategy B implementation

@@ -1293,10 +1106,10 @@ typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (emptyRelationWithAt

12931106typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

12941107 mAttrs <- case mAttrExprs of

12951108 Just attrExprs -> do

1296− attrs <- mapM (\e -> evalGraphRefAttributeExpr e) attrExprs

1109+ attrs <- mapM evalGraphRefAttributeExpr attrExprs

12971110 pure (Just (attributesFromList attrs))

12981111 Nothing -> pure Nothing

1299− tuples <- mapM (evalGraphRefTupleExpr mAttrs) tupleExprs

1112+ tuples <- evalGraphRefTupleExprs mAttrs tupleExprs

13001113 let retAttrs = case tuples of

13011114 (tup:_) -> tupleAttributes tup

13021115 [] -> fromMaybe A.emptyAttributes mAttrs

@@ -1306,7 +1119,8 @@ typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do

13061119 relVars <- relationVariables <$> gfDatabaseContextForMarker tid

13071120 case M.lookup rvName relVars of

13081121 Nothing -> throwError (RelVarNotDefinedError rvName)

1309− Just rvExpr -> typeForGraphRefRelationalExpr rvExpr

1122+ Just rvExpr ->

1123+ typeForGraphRefRelationalExpr rvExpr

13101124typeForGraphRefRelationalExpr (Project attrNames expr) = do

13111125 exprType' <- typeForGraphRefRelationalExpr expr

13121126 projectionAttrs <- evalGraphRefAttributeNames attrNames expr

@@ -1337,15 +1151,21 @@ typeForGraphRefRelationalExpr (Restrict pred' expr) = do

13371151 expr' <- typeForGraphRefRelationalExpr expr

13381152 filt <- predicateRestrictionFilter (attributes expr') pred'

13391153 lift $ except $ restrict filt expr'

1340−typeForGraphRefRelationalExpr Equals{} = do

1154+typeForGraphRefRelationalExpr Equals{} =

13411155 pure relationFalse

1342−typeForGraphRefRelationalExpr NotEquals{} = do

1156+typeForGraphRefRelationalExpr NotEquals{} =

13431157 pure relationFalse

13441158typeForGraphRefRelationalExpr (Extend extendTupleExpr expr) = do

13451159 rel <- typeForGraphRefRelationalExpr expr

13461160 evalGraphRefRelationalExpr (Extend extendTupleExpr (ExistingRelation rel))

1347−typeForGraphRefRelationalExpr expr@With{} = do

1161+typeForGraphRefRelationalExpr expr@(With withs _) = do

13481162 let expr' = substituteWithNameMacros [] expr

1163+ checkMacroName (WithNameExpr macroName tid) = do

1164+ rvs <- relationVariables <$> gfDatabaseContextForMarker tid

1165+ case M.lookup macroName rvs of

1166+ Just _ -> lift $ except $ Left (RelVarAlreadyDefinedError macroName) --this error does not include the transaction marker, but should be good enough to identify the cause

1167+ Nothing -> pure ()

1168+ mapM_ (checkMacroName . fst) withs

13491169 typeForGraphRefRelationalExpr expr'

13501170

13511171evalGraphRefAttributeNames :: GraphRefAttributeNames -> GraphRefRelationalExpr -> GraphRefRelationalExprM (S.Set AttributeName)

@@ -1361,7 +1181,7 @@ evalGraphRefAttributeNames attrNames expr = do

13611181 InvertedAttributeNames names -> do

13621182 let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet

13631183 if not (S.null nonExistentAttributeNames) then

1364− throwError (AttributeNamesMismatchError nonExistentAttributeNames)

1184+ throwError $ AttributeNamesMismatchError nonExistentAttributeNames

13651185 else

13661186 pure (A.nonMatchingAttributeNameSet names typeNameSet)

13671187

@@ -1391,9 +1211,9 @@ evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do

13911211evalGraphRefAttributeExpr (NakedAttributeExpr attr) = pure attr

13921212

13931213mkEmptyRelVars :: RelationVariables -> RelationVariables

1394−mkEmptyRelVars rvMap = M.map mkEmptyRelVar rvMap

1214+mkEmptyRelVars = M.map mkEmptyRelVar

13951215 where

1396− mkEmptyRelVar (MakeRelationFromExprs mAttrs _) = MakeRelationFromExprs mAttrs []

1216+ mkEmptyRelVar expr@MakeRelationFromExprs{} = expr --do not truncate here because we might lose essential type information in emptying the tuples

13971217 mkEmptyRelVar (MakeStaticRelation attrs _) = MakeStaticRelation attrs emptyTupleSet

13981218 mkEmptyRelVar (ExistingRelation rel) = ExistingRelation (emptyRelationWithAttrs (attributes rel))

13991219 mkEmptyRelVar rv@RelationVariable{} = Restrict (NotPredicate TruePredicate) rv

@@ -1408,7 +1228,7 @@ mkEmptyRelVars rvMap = M.map mkEmptyRelVar rvMap

14081228 mkEmptyRelVar (Equals exprA exprB) = Equals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)

14091229 mkEmptyRelVar (NotEquals exprA exprB) = NotEquals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)

14101230 mkEmptyRelVar (Extend extTuple expr) = Extend extTuple (mkEmptyRelVar expr)

1411− mkEmptyRelVar (With macros expr) = With (map (\(rv, expr') -> (rv, mkEmptyRelVar expr')) macros) (mkEmptyRelVar expr)

1231+ mkEmptyRelVar (With macros expr) = With (map (second mkEmptyRelVar) macros) (mkEmptyRelVar expr)

14121232

14131233

14141234dbErr :: RelationalError -> DatabaseContextEvalMonad ()

@@ -1425,7 +1245,7 @@ relationVariablesAsRelation ctx graph = do

14251245 let gfEnv = freshGraphRefRelationalExprEnv (Just ctx) graph

14261246 gfType <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

14271247 pure (rvName, gfType)

1428− relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributes rel)]

1248+ relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributesVec (attributes rel))]

14291249 attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]

14301250 attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of

14311251 Left err -> error ("relationVariablesAsRelation pooped " ++ show err)

@@ -1445,15 +1265,6 @@ evalRelationalExpr expr = do

14451265 Left err -> throwError err

14461266 Right rel -> pure rel

14471267

1448−{-

1449−relVarByName :: RelVarName -> GraphRefRelationalExprM GraphRefRelationalExpr

1450−relVarByName = do

1451− relvars <- relationVariables <$> getStateContext

1452− case M.lookup relVarName relvars of

1453− Nothing -> dbErr (RelVarNotDefinedError relVarName)

1454− Just gfexpr -> pure gfExpr

1455−-}

1456−

14571268class (MonadError RelationalError m, Monad m) => DatabaseContextM m where

14581269 getContext :: m DatabaseContext

14591270

@@ -1470,3 +1281,112 @@ relVarByName rvName = do

14701281 Nothing -> throwError (RelVarNotDefinedError rvName)

14711282 Just gfexpr -> pure gfexpr

14721283

1284+-- | resolve UncommittedTransactionMarker whenever possible- this is important in the DatabaseContext in order to mitigate self-referencing loops for updates

1285+class ResolveGraphRefTransactionMarker a where

1286+ resolve :: a -> DatabaseContextEvalMonad a

1287+

1288+-- s := s union t

1289+instance ResolveGraphRefTransactionMarker GraphRefRelationalExpr where

1290+ resolve (MakeRelationFromExprs mAttrs tupleExprs) =

1291+ MakeRelationFromExprs mAttrs <$> resolve tupleExprs

1292+ resolve orig@MakeStaticRelation{} = pure orig

1293+ resolve orig@ExistingRelation{} = pure orig

1294+ resolve orig@(RelationVariable rvName UncommittedContextMarker) = do

1295+ rvMap <- relationVariables <$> getStateContext

1296+ case M.lookup rvName rvMap of

1297+ Nothing -> pure orig

1298+ Just resolvedRv -> resolve resolvedRv

1299+ resolve orig@RelationVariable{} = pure orig

1300+ resolve (Project attrNames relExpr) = Project <$> resolve attrNames <*> resolve relExpr

1301+ resolve (Union exprA exprB) = Union <$> resolve exprA <*> resolve exprB

1302+ resolve (Join exprA exprB) = Join <$> resolve exprA <*> resolve exprB

1303+ resolve (Rename attrA attrB expr) = Rename attrA attrB <$> resolve expr

1304+ resolve (Difference exprA exprB) = Difference <$> resolve exprA <*> resolve exprB

1305+ resolve (Group namesA nameB expr) = Group <$> resolve namesA <*> pure nameB <*> resolve expr

1306+ resolve (Ungroup nameA expr) = Ungroup nameA <$> resolve expr

1307+ resolve (Restrict restrictExpr relExpr) = Restrict <$> resolve restrictExpr <*> resolve relExpr

1308+ resolve (Equals exprA exprB) = Equals <$> resolve exprA <*> resolve exprB

1309+ resolve (NotEquals exprA exprB) = NotEquals <$> resolve exprA <*> resolve exprB

1310+ resolve (Extend extendExpr relExpr) = Extend <$> resolve extendExpr <*> resolve relExpr

1311+ resolve (With withExprs relExpr) = With <$> mapM (\(nam, expr) -> (,) <$> resolve nam <*> resolve expr) withExprs <*> resolve relExpr

1312+

1313+instance ResolveGraphRefTransactionMarker GraphRefTupleExprs where

1314+ resolve (TupleExprs marker tupleExprs) =

1315+ TupleExprs marker <$> mapM resolve tupleExprs

1316+

1317+instance ResolveGraphRefTransactionMarker GraphRefTupleExpr where

1318+ resolve (TupleExpr tupMap) = do

1319+ tupMap' <- mapM (\(attrName, expr) -> (,) attrName <$> resolve expr ) (M.toList tupMap)

1320+ pure (TupleExpr (M.fromList tupMap'))

1321+

1322+instance ResolveGraphRefTransactionMarker GraphRefAttributeNames where

1323+ resolve orig@AttributeNames{} = pure orig

1324+ resolve orig@InvertedAttributeNames{} = pure orig

1325+ resolve (UnionAttributeNames namesA namesB) = UnionAttributeNames <$> resolve namesA <*> resolve namesB

1326+ resolve (IntersectAttributeNames namesA namesB) = IntersectAttributeNames <$> resolve namesA <*> resolve namesB

1327+ resolve (RelationalExprAttributeNames expr) = RelationalExprAttributeNames <$> resolve expr

1328+

1329+instance ResolveGraphRefTransactionMarker GraphRefRestrictionPredicateExpr where

1330+ resolve TruePredicate = pure TruePredicate

1331+ resolve (AndPredicate exprA exprB) = AndPredicate <$> resolve exprA <*> resolve exprB

1332+ resolve (OrPredicate exprA exprB) = OrPredicate <$> resolve exprA <*> resolve exprB

1333+ resolve (NotPredicate expr) = NotPredicate <$> resolve expr

1334+ resolve (RelationalExprPredicate expr) = RelationalExprPredicate <$> resolve expr

1335+ resolve (AtomExprPredicate expr) = AtomExprPredicate <$> resolve expr

1336+ resolve (AttributeEqualityPredicate nam expr)= AttributeEqualityPredicate nam <$> resolve expr

1337+

1338+instance ResolveGraphRefTransactionMarker GraphRefExtendTupleExpr where

1339+ resolve (AttributeExtendTupleExpr nam atomExpr) = AttributeExtendTupleExpr nam <$> resolve atomExpr

1340+

1341+instance ResolveGraphRefTransactionMarker GraphRefWithNameExpr where

1342+ resolve orig@WithNameExpr{} = pure orig -- match uncommitted marker?

1343+

1344+instance ResolveGraphRefTransactionMarker GraphRefAtomExpr where

1345+ resolve orig@AttributeAtomExpr{} = pure orig

1346+ resolve orig@NakedAtomExpr{} = pure orig

1347+ resolve (FunctionAtomExpr nam atomExprs marker) =

1348+ FunctionAtomExpr nam <$> mapM resolve atomExprs <*> pure marker

1349+ resolve (RelationAtomExpr expr) = RelationAtomExpr <$> resolve expr

1350+ resolve (ConstructedAtomExpr dConsName atomExprs marker) =

1351+ ConstructedAtomExpr dConsName <$> mapM resolve atomExprs <*> pure marker

1352+

1353+--convert series of simple Union queries into MakeStaticRelation

1354+-- this is especially useful for long, nested applications of Union with simple tuples

1355+-- Union (MakeRelation x y) (MakeRelation x y') -> MakeRelation x (y + y')

1356+

1357+--MakeRelationFromExprs Nothing (TupleExprs UncommittedContextMarker [TupleExpr (fromList [("name", NakedAtomExpr (TextAtom "steve"))])])

1358+

1359+applyUnionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr

1360+applyUnionCollapse = Fold.cata opt

1361+ where

1362+ opt :: RelationalExprBaseF GraphRefTransactionMarker GraphRefRelationalExpr -> GraphRefRelationalExpr

1363+ opt (UnionF exprA exprB) | exprA == exprB = exprA

1364+ opt (UnionF

1365+ exprA@(MakeRelationFromExprs mAttrs1 tupExprs1)

1366+ exprB@(MakeRelationFromExprs mAttrs2 tupExprs2)) | tupExprs1 == tupExprs2 = MakeRelationFromExprs (mAttrs1 <|> mAttrs2) tupExprs1

1367+ | tupExprsNull tupExprs1 = exprB

1368+ | tupExprsNull tupExprs2 = exprA

1369+ opt x = Fold.embed x

1370+ tupExprsNull (TupleExprs _ []) = True

1371+ tupExprsNull _ = False

1372+

1373+

1374+--UPDATE optimization- find matching where clause in "lower" levels of renaming

1375+--update x where y=1 set (x:=5,z:=10); update x where y=1 set(x:=6,z:=11)

1376+-- =>

1377+-- update x where y=1 set (x:=6,z:=11)

1378+-- future opt: match individual attributes update x where y=1 set (x:=5); update x where y=1 set (z:=11) => update x where y=1 set (x:=5,z:=11)

1379+

1380+--strategy: try to collapse the top-level update (union (restrict pred MakeRelationFromExpr) expr) if it contains the same predicate and resultant relation

1381+

1382+--DELETE optimization

1383+-- if a restriction matches a previous restriction, combine them

1384+-- O(1) since it only scans at the top level, critical in benchmarks generating redundant deletions

1385+applyRestrictionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr

1386+applyRestrictionCollapse orig@(Restrict npred@(NotPredicate _) expr) =

1387+ case expr of

1388+ orig'@(Restrict npred'@(NotPredicate _) _) | npred == npred' -> orig'

1389+ _ -> orig

1390+applyRestrictionCollapse expr = expr

1391+

1392+

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

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

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

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

2+#ifdef PM36_HASKELL_SCRIPTING

3+{-# LANGUAGE MagicHash #-}

4+#endif

25module ProjectM36.ScriptSession where

7+#ifdef PM36_HASKELL_SCRIPTING

48import ProjectM36.Error

5−

9+import GHC

610import Control.Exception

711import Control.Monad

812import System.IO.Error

@@ -13,9 +17,8 @@ import System.FilePath

1317import System.Info (os, arch)

1418import Data.Text (Text, unpack)

1519import Data.Maybe

16−

17−import GHC

1820import GHC.Paths (libdir)

21+import System.Environment

1922#if __GLASGOW_HASKELL__ >= 800

2023import GHC.LanguageExtensions

2124import GHCi.ObjLink

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

3336#if __GLASGOW_HASKELL__ >= 802

3437import Type

3538#elif __GLASGOW_HASKELL__ >= 710

36−import Type hiding (pprTyThing)

39+import Type hiding (pprTyThing)

3740#else

3841#endif

39−

4042import GHC.Exts (addrToAny#)

4143import GHC.Ptr (Ptr(..))

4244import Encoding

45+#endif

46+

4347

4448data ScriptSession = ScriptSession {

45− hscEnv :: HscEnv,

49+#ifdef PM36_HASKELL_SCRIPTING

50+ hscEnv :: HscEnv,

4651 atomFunctionBodyType :: Type,

4752 dbcFunctionBodyType :: Type

53+#endif

4854 }

49−

50−newtype ScriptSessionError = ScriptSessionLoadError GhcException

55+

56+#ifdef PM36_HASKELL_SCRIPTING

57+data ScriptSessionError = ScriptSessionLoadError GhcException

58+ | ScriptingDisabled

5159 deriving (Show)

60+#else

61+data ScriptSessionError = ScriptingDisabled

62+ deriving (Show)

63+#endif

64+

65+data LoadSymbolError = LoadSymbolError

66+type ModName = String

67+type FuncName = String

5268

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

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

71+#if !defined(PM36_HASKELL_SCRIPTING)

72+initScriptSession _ = pure (Left ScriptingDisabled)

73+#else

5574initScriptSession ghcPkgPaths = do

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

5776 eHomeDir <- tryJust (guard . isDoesNotExistError) getHomeDirectory

@@ -60,28 +79,30 @@ initScriptSession ghcPkgPaths = do

6079 handleGhcException excHandler $ runGhc (Just libdir) $ do

6180 dflags <- getSessionDynFlags

6281 let ghcVersion = projectVersion dflags

82+ -- get nix packages dir, if available

83+ mNixLibDir <- liftIO $ lookupEnv "NIX_GHC_LIBDIR"

6384

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

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

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

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

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

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

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

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

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

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

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

7293 ]

73−

74− let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths)

75−

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

77− ghcLink = LinkInMemory,

94+

95+ let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths ++ maybeToList mNixLibDir)

96+

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

98+ ghcLink = LinkInMemory,

7899 safeHaskell = Sf_Trustworthy,

79100 safeInfer = True,

80101 safeInferred = True,

81102 --verbosity = 3,

82−#if __GLASGOW_HASKELL__ >= 800

103+#if __GLASGOW_HASKELL__ >= 800

83104 trustFlags = map TrustPackage required_packages,

84−#endif

105+#endif

85106 packageFlags = packageFlags dflags ++ packages,

86107#if __GLASGOW_HASKELL__ >= 802

87108 packageDBFlags = map PackageDB localPkgPaths

@@ -94,11 +115,11 @@ initScriptSession ghcPkgPaths = do

94115 applyXopts flags = foldl xopt_set flags xopts

95116#if __GLASGOW_HASKELL__ >= 800

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

97−#else

118+#else

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

99120#endif

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

101− required_packages = ["base",

122+ required_packages = ["base",

102123 "containers",

103124 "Glob",

104125 "directory",

@@ -107,8 +128,6 @@ initScriptSession ghcPkgPaths = do

107128 "uuid",

108129 "vector",

109130 "text",

110− "binary",

111− "vector-binary-instances",

112131 "time",

113132 "project-m36",

114133 "bytestring"]

@@ -120,20 +139,33 @@ initScriptSession ghcPkgPaths = do

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

121140 _ <- setSessionDynFlags dflags'

122141 let safeImportDecl mn mQual = ImportDecl {

123−#if __GLASGOW_HASKELL__ >= 802

142+#if __GLASGOW_HASKELL__ >= 802

124143 ideclSourceSrc = NoSourceText,

125144#else

126145 ideclSourceSrc = Nothing,

127146#endif

147+

148+#if __GLASGOW_HASKELL__ >= 810

149+ ideclExt = noExtField,

150+#elif __GLASGOW_HASKELL__ >= 806

151+ ideclExt = NoExt,

152+#endif

128153 ideclName = noLoc mn,

129154 ideclPkgQual = Nothing,

130155 ideclSource = False,

131156 ideclSafe = True,

132157 ideclImplicit = False,

158+#if __GLASGOW_HASKELL__ >= 810

159+ ideclQualified = if isJust mQual then QualifiedPre else NotQualified,

160+#else

133161 ideclQualified = isJust mQual,

162+#endif

134163 ideclAs = mQual,

135164 ideclHiding = Nothing

136165 }

166+#if __GLASGOW_HASKELL__ >= 806

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

168+#endif

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

138170 "Prelude",

139171 "Data.Map",

@@ -150,7 +182,7 @@ initScriptSession ghcPkgPaths = do

150182 mkModName = noLoc . mkModuleName

151183#else

152184 mkModName = mkModuleName

153−#endif

185+#endif

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

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

156188 ]

@@ -163,8 +195,8 @@ initScriptSession ghcPkgPaths = do

163195addImport :: String -> Ghc ()

164196addImport moduleNam = do

165197 ctx <- getContext

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

167−

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

199+

168200showType :: DynFlags -> Type -> String

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

170202

@@ -189,41 +221,36 @@ compileScript funcType script = do

189221 mErr <- typeCheckScript funcType script

190222 case mErr of

191223 Just err -> pure (Left err)

192− Nothing ->

224+ Nothing ->

193225 --catch exception here

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

195227 -- we can't use dynCompileExpr here because

196228 Right . unsafeCoerce <$> compileExpr sScript

197−

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

229+

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

199231typeCheckScript expectedType inp = do

200− dflags <- getSessionDynFlags

232+ dflags <- getSessionDynFlags

201233 --catch exception for SyntaxError

202234#if __GLASGOW_HASKELL__ >= 802

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

204−#else

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

236+#else

205237 funcType <- GHC.exprType (unpack inp)

206238#endif

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

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

208240 if eqType funcType expectedType then

209241 pure Nothing

210242 else

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

212−

244+

213245mangleSymbol :: Maybe String -> String -> String -> String

214246mangleSymbol pkg module' valsym =

215247 prefixUnderscore ++

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

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

218−

219−type ModName = String

220−type FuncName = String

221−

222−data LoadSymbolError = LoadSymbolError

223250

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

225252loadFunction modName funcName objPath = do

226−#if __GLASGOW_HASKELL__ >= 802

253+#if __GLASGOW_HASKELL__ >= 802

227254 initObjLinker RetainCAFs

228255#else

229256 initObjLinker

@@ -235,8 +262,8 @@ loadFunction modName funcName objPath = do

235262 Nothing -> pure (Left LoadSymbolError)

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

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

238−

239−prefixUnderscore :: String

265+

266+prefixUnderscore :: String

240267prefixUnderscore =

241268 case (os,arch) of

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

@@ -244,4 +271,5 @@ prefixUnderscore =

244271 ("mingw32",_) -> "_"

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

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

247− _ -> ""

274+ _ -> ""

275+#endif

src/lib/ProjectM36/Serialise/AtomFunctionError.hsnew file+7

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

1+{-# LANGUAGE DerivingVia, StandaloneDeriving #-}

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

3+module ProjectM36.Serialise.AtomFunctionError where

4+import Codec.Winery

5+import ProjectM36.AtomFunctionError

7+deriving via WineryVariant AtomFunctionError instance Serialise AtomFunctionError

src/lib/ProjectM36/Serialise/Base.hsnew file+85

@@ -0,0 +1,85 @@

1+{-# LANGUAGE StandaloneDeriving, DerivingVia, TypeApplications, TypeSynonymInstances, ScopedTypeVariables #-}

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

3+--Serialise instances for ProjectM36.Base data types- orphan instance city

4+module ProjectM36.Serialise.Base where

5+import Codec.Winery hiding (Schema)

6+import Codec.Winery.Internal

7+import Control.Monad

8+import ProjectM36.Base

9+import ProjectM36.MerkleHash

10+import Data.UUID

11+import Data.Proxy

12+import Data.Word

13+import ProjectM36.Attribute as A

14+import qualified Data.List.NonEmpty as NE

15+import qualified Data.Vector as V

16+import Data.Time.Calendar (Day,toGregorian,fromGregorian)

17+

18+deriving via WineryVariant Atom instance Serialise Atom

19+deriving via WineryVariant AtomType instance Serialise AtomType

20+deriving via WineryVariant Attribute instance Serialise Attribute

21+deriving via WineryVariant RelationTupleSet instance Serialise RelationTupleSet

22+deriving via WineryVariant RelationTuple instance Serialise RelationTuple

23+deriving via WineryVariant Relation instance Serialise Relation

24+deriving via WineryVariant RelationCardinality instance Serialise RelationCardinality

25+deriving via WineryVariant (RelationalExprBase a) instance Serialise a => Serialise (RelationalExprBase a)

26+deriving via WineryVariant (WithNameExprBase a) instance Serialise a => Serialise (WithNameExprBase a)

27+deriving via WineryVariant Notification instance Serialise Notification

28+deriving via WineryVariant TypeConstructorDef instance Serialise TypeConstructorDef

29+deriving via WineryVariant (TypeConstructorBase a) instance Serialise a => Serialise (TypeConstructorBase a)

30+deriving via WineryVariant DataConstructorDef instance Serialise DataConstructorDef

31+deriving via WineryVariant DataConstructorDefArg instance Serialise DataConstructorDefArg

32+deriving via WineryVariant GraphRefTransactionMarker instance Serialise GraphRefTransactionMarker

33+deriving via WineryVariant SchemaIsomorph instance Serialise SchemaIsomorph

34+deriving via WineryVariant InclusionDependency instance Serialise InclusionDependency

35+deriving via WineryVariant (DatabaseContextExprBase a) instance Serialise a => Serialise (DatabaseContextExprBase a)

36+deriving via WineryVariant (DatabaseContextIOExprBase a) instance Serialise a => Serialise (DatabaseContextIOExprBase a)

37+deriving via WineryVariant (RestrictionPredicateExprBase a) instance Serialise a => Serialise (RestrictionPredicateExprBase a)

38+deriving via WineryVariant TransactionInfo instance Serialise TransactionInfo

39+deriving via WineryVariant (AtomExprBase a) instance Serialise a => Serialise (AtomExprBase a)

40+deriving via WineryVariant MerkleHash instance Serialise MerkleHash

41+deriving via WineryVariant (AttributeExprBase a) instance Serialise a => Serialise (AttributeExprBase a)

42+deriving via WineryVariant (TupleExprsBase a) instance Serialise a => Serialise (TupleExprsBase a)

43+deriving via WineryVariant (TupleExprBase a) instance Serialise a => Serialise (TupleExprBase a)

44+deriving via WineryVariant (AttributeNamesBase a) instance Serialise a => Serialise (AttributeNamesBase a)

45+deriving via WineryVariant (ExtendTupleExprBase a) instance Serialise a => Serialise (ExtendTupleExprBase a)

46+deriving via WineryVariant Schema instance Serialise Schema

47+deriving via WineryVariant MergeStrategy instance Serialise MergeStrategy

48+

49+fromWordsTup :: (Word32, Word32, Word32, Word32) -> TransactionId

50+fromWordsTup (a,b,c,d) = fromWords a b c d

51+

52+instance Serialise TransactionId where

53+ schemaGen _ = getSchema (Proxy @(Word32, Word32, Word32, Word32))

54+ toBuilder uuid = toBuilder (toWords uuid)

55+ extractor = fromWordsTup <$> extractor

56+ decodeCurrent = fromWordsTup <$> decodeCurrent

57+

58+instance Serialise a => Serialise (NE.NonEmpty a) where

59+ schemaGen _ = SVector <$> getSchema (Proxy @a)

60+ toBuilder xs = varInt (length xs) <> foldMap toBuilder xs

61+ extractor = NE.fromList . V.toList <$> extractListBy extractor --use nonempty instead to replace error with winery error

62+ decodeCurrent = do

63+ n <- decodeVarInt

64+ l <- replicateM n decodeCurrent

65+ pure (NE.fromList l)

66+

67+fromGregorianTup :: (Integer, Int, Int) -> Day

68+fromGregorianTup (a, b, c) = fromGregorian a b c

69+

70+instance Serialise Day where

71+ schemaGen _ = getSchema (Proxy @(Integer, Int, Int))

72+ toBuilder day = toBuilder (toGregorian day)

73+ extractor = fromGregorianTup <$> extractor

74+ decodeCurrent = fromGregorianTup <$> decodeCurrent

75+

76+instance Serialise Attributes where

77+ schemaGen _ = SVector <$> getSchema (Proxy @Attribute)

78+ toBuilder attrs = varInt (V.length (attributesVec attrs)) <> foldMap toBuilder (V.toList (attributesVec attrs))

79+ extractor =

80+ attributesFromList . V.toList <$> extractListBy extractor

81+

82+ decodeCurrent = do

83+ n <- decodeVarInt

84+ l <- replicateM n decodeCurrent

85+ pure (A.attributesFromList l)

src/lib/ProjectM36/Serialise/DataFrame.hsnew file+13

@@ -0,0 +1,13 @@

1+{-# LANGUAGE DerivingVia, StandaloneDeriving #-}

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

3+module ProjectM36.Serialise.DataFrame where

4+import Codec.Winery

5+import ProjectM36.DataFrame

6+import ProjectM36.Serialise.Base ()

8+deriving via WineryVariant AttributeOrderExpr instance Serialise AttributeOrderExpr

9+deriving via WineryVariant AttributeOrder instance Serialise AttributeOrder

10+deriving via WineryVariant Order instance Serialise Order

11+deriving via WineryRecord DataFrame instance Serialise DataFrame

12+deriving via WineryVariant DataFrameTuple instance Serialise DataFrameTuple

13+deriving via WineryRecord DataFrameExpr instance Serialise DataFrameExpr

src/lib/ProjectM36/Serialise/DatabaseContextFunctionError.hsnew file+7

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

1+{-# LANGUAGE DerivingVia, StandaloneDeriving #-}

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

3+module ProjectM36.Serialise.DatabaseContextFunctionError where

4+import Codec.Winery

5+import ProjectM36.DatabaseContextFunctionError

7+deriving via WineryVariant DatabaseContextFunctionError instance Serialise DatabaseContextFunctionError

src/lib/ProjectM36/Serialise/Error.hsnew file+15

@@ -0,0 +1,15 @@

1+{-# LANGUAGE DerivingVia, StandaloneDeriving #-}

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

3+module ProjectM36.Serialise.Error where

4+import ProjectM36.Error

5+import Codec.Winery

6+import ProjectM36.Serialise.Base ()

7+import ProjectM36.Serialise.AtomFunctionError ()

8+import ProjectM36.Serialise.DatabaseContextFunctionError ()

10+deriving via WineryVariant RelationalError instance Serialise RelationalError

11+deriving via WineryVariant MergeError instance Serialise MergeError

12+deriving via WineryVariant ScriptCompilationError instance Serialise ScriptCompilationError

13+deriving via WineryVariant PersistenceError instance Serialise PersistenceError

14+deriving via WineryVariant SchemaError instance Serialise SchemaError

15+deriving via WineryVariant ImportError' instance Serialise ImportError'

src/lib/ProjectM36/Serialise/IsomorphicSchema.hsnew file+7

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

1+{-# LANGUAGE StandaloneDeriving, DerivingVia, TypeSynonymInstances, ScopedTypeVariables #-}

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

3+module ProjectM36.Serialise.IsomorphicSchema where

4+import Codec.Winery

5+import ProjectM36.IsomorphicSchema

7+deriving via WineryVariant SchemaExpr instance Serialise SchemaExpr

src/lib/ProjectM36/Serialise/MergeError.hsnew file+1

@@ -0,0 +1 @@

src/lib/ProjectM36/Server.hs+166−99

@@ -7,80 +7,119 @@ import ProjectM36.Server.RemoteCallTypes

77import ProjectM36.Server.Config (ServerConfig(..))

88import ProjectM36.FSType

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

11−#if MIN_VERSION_network_transport_tcp(0,7,0)

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

13−#else

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

15−#endif

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

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

18−import Control.Distributed.Process.Extras.Time (Delay(..))

19−import Control.Distributed.Process (Process, register, getSelfPid)

20−import Control.Distributed.Process.ManagedProcess (defaultProcess, UnhandledMessagePolicy(..), ProcessDefinition(..), handleCall, serve, InitHandler, InitResult(..))

21−import Control.Concurrent.MVar (putMVar, MVar)

10+import Control.Concurrent.MVar (MVar)

2211import System.IO (stderr, hPutStrLn)

2312import System.FilePath (takeDirectory)

2413import System.Directory (doesDirectoryExist)

14+import Network.RPC.Curryer.Server

15+import Network.Socket

16+import qualified StmContainers.Map as StmMap

17+import Control.Concurrent.STM

2518

26−-- the state should be a mapping of remote connection to the disconnected transaction- the graph should be the same, so discon must be removed from the stm tuple

27−--trying to refactor this for less repetition is very challenging because the return type cannot be polymorphic or the distributed-process call gets confused and drops messages

28−serverDefinition :: Bool -> Timeout -> ProcessDefinition Connection

29−serverDefinition testBool ti = defaultProcess {

30− apiHandlers = [

31− handleCall (\conn (ExecuteHeadName sessionId) -> handleExecuteHeadName ti sessionId conn),

32− handleCall (\conn (ExecuteRelationalExpr sessionId expr) -> handleExecuteRelationalExpr ti sessionId conn expr),

33− handleCall (\conn (ExecuteDataFrameExpr sessionId expr) -> handleExecuteDataFrameExpr ti sessionId conn expr),

34− handleCall (\conn (ExecuteDatabaseContextExpr sessionId expr) -> handleExecuteDatabaseContextExpr ti sessionId conn expr),

35− handleCall (\conn (ExecuteDatabaseContextIOExpr sessionId expr) -> handleExecuteDatabaseContextIOExpr ti sessionId conn expr),

36− handleCall (\conn (ExecuteGraphExpr sessionId expr) -> handleExecuteGraphExpr ti sessionId conn expr),

37− handleCall (\conn (ExecuteTransGraphRelationalExpr sessionId expr) -> handleExecuteTransGraphRelationalExpr ti sessionId conn expr),

38− handleCall (\conn (ExecuteTypeForRelationalExpr sessionId expr) -> handleExecuteTypeForRelationalExpr ti sessionId conn expr),

39− handleCall (\conn (RetrieveInclusionDependencies sessionId) -> handleRetrieveInclusionDependencies ti sessionId conn),

40− handleCall (\conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr) -> handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr),

41− handleCall (\conn (RetrieveHeadTransactionId sessionId) -> handleRetrieveHeadTransactionId ti sessionId conn),

42− handleCall (\conn (RetrieveTransactionGraph sessionId) -> handleRetrieveTransactionGraph ti sessionId conn),

43− handleCall (\conn (Login procId) -> handleLogin ti conn procId),

44− handleCall (\conn (CreateSessionAtHead headn) -> handleCreateSessionAtHead ti conn headn),

45− handleCall (\conn (CreateSessionAtCommit commitId) -> handleCreateSessionAtCommit ti conn commitId),

46− handleCall (\conn (CloseSession sessionId) -> handleCloseSession ti sessionId conn),

47− handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation ti sessionId conn),

48− handleCall (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary ti sessionId conn),

49− handleCall (\conn (RetrieveAtomFunctionSummary sessionId) -> handleRetrieveAtomFunctionSummary ti sessionId conn),

50− handleCall (\conn (RetrieveDatabaseContextFunctionSummary sessionId) -> handleRetrieveDatabaseContextFunctionSummary ti sessionId conn),

51− handleCall (\conn (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName ti sessionId conn),

52− handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr),

53− handleCall (\conn (RetrieveSessionIsDirty sessionId) -> handleRetrieveSessionIsDirty ti sessionId conn),

54− handleCall (\conn (ExecuteAutoMergeToHead sessionId strat headName') -> handleExecuteAutoMergeToHead ti sessionId conn strat headName'),

55− handleCall (\conn (RetrieveTypeConstructorMapping sessionId) -> handleRetrieveTypeConstructorMapping ti sessionId conn),

56− handleCall (\conn Logout -> handleLogout ti conn)

57− ] ++ testModeHandlers,

58− unhandledMessagePolicy = Terminate

59− --unhandledMessagePolicy = Log

60− }

61− where

62− testModeHandlers = if not testBool then

63− []

64− else

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

66−

67−

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

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

70− registerDB dbname

71− case mAddressMVar of

72− Nothing -> pure ()

73− Just addressMVar -> liftIO $ putMVar addressMVar saddress

74− --traceShowM ("server started on " ++ show saddress)

75− pure $ InitOk conn Infinity

19+type TestMode = Bool

7620

77−registerDB :: DatabaseName -> Process ()

78−registerDB dbname = do

79− self <- getSelfPid

80− let dbname' = remoteDBLookupName dbname

81− register dbname' self

82− --liftIO $ putStrLn $ "registered " ++ (show self) ++ " " ++ dbname'

83−

21+requestHandlers :: TestMode -> Maybe Timeout -> RequestHandlers ServerState

22+requestHandlers testFlag ti =

23+ [

24+ RequestHandler (\sState (Login dbName) -> do

25+ addClientLogin dbName sState

26+ conn <- getConn sState

27+ handleLogin conn (connectionSocket sState)),

28+ RequestHandler (\sState Logout -> do

29+ conn <- getConn sState

30+ handleLogout ti conn),

31+ RequestHandler $ \sState (ExecuteHeadName sessionId) -> do

32+ --socket -> dbname --maybe create a socket->client state mapping in the server state, too

33+ conn <- getConn sState

34+ handleExecuteHeadName ti sessionId conn,

35+ RequestHandler (\sState (ExecuteRelationalExpr sessionId expr) -> do

36+ conn <- getConn sState

37+ handleExecuteRelationalExpr ti sessionId conn expr),

38+ RequestHandler (\sState (ExecuteDataFrameExpr sessionId expr) -> do

39+ conn <- getConn sState

40+ handleExecuteDataFrameExpr ti sessionId conn expr),

41+ RequestHandler (\sState (ExecuteDatabaseContextExpr sessionId expr) -> do

42+ conn <- getConn sState

43+ handleExecuteDatabaseContextExpr ti sessionId conn expr),

44+ RequestHandler (\sState (ExecuteDatabaseContextIOExpr sessionId expr) -> do

45+ conn <- getConn sState

46+ handleExecuteDatabaseContextIOExpr ti sessionId conn expr),

47+ RequestHandler (\sState (ExecuteGraphExpr sessionId expr) -> do

48+ conn <- getConn sState

49+ handleExecuteGraphExpr ti sessionId conn expr),

50+ RequestHandler (\sState (ExecuteTransGraphRelationalExpr sessionId expr) -> do

51+ conn <- getConn sState

52+ handleExecuteTransGraphRelationalExpr ti sessionId conn expr),

53+ RequestHandler (\sState (ExecuteTypeForRelationalExpr sessionId expr) -> do

54+ conn <- getConn sState

55+ handleExecuteTypeForRelationalExpr ti sessionId conn expr),

56+ RequestHandler (\sState (RetrieveInclusionDependencies sessionId) -> do

57+ conn <- getConn sState

58+ handleRetrieveInclusionDependencies ti sessionId conn),

59+ RequestHandler (\sState (RetrievePlanForDatabaseContextExpr sessionId dbExpr) -> do

60+ conn <- getConn sState

61+ handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr),

62+ RequestHandler (\sState (RetrieveHeadTransactionId sessionId) -> do

63+ conn <- getConn sState

64+ handleRetrieveHeadTransactionId ti sessionId conn),

65+ RequestHandler (\sState (RetrieveTransactionGraph sessionId) -> do

66+ conn <- getConn sState

67+ handleRetrieveTransactionGraph ti sessionId conn),

68+ RequestHandler (\sState (CreateSessionAtHead headn) -> do

69+ conn <- getConn sState

70+ handleCreateSessionAtHead ti conn headn),

71+ RequestHandler (\sState (CreateSessionAtCommit commitId) -> do

72+ conn <- getConn sState

73+ handleCreateSessionAtCommit ti conn commitId),

74+ RequestHandler (\sState (CloseSession sessionId) -> do

75+ conn <- getConn sState

76+ handleCloseSession sessionId conn),

77+ RequestHandler (\sState (RetrieveAtomTypesAsRelation sessionId) -> do

78+ conn <- getConn sState

79+ handleRetrieveAtomTypesAsRelation ti sessionId conn),

80+ RequestHandler (\sState (RetrieveRelationVariableSummary sessionId) -> do

81+ conn <- getConn sState

82+ handleRetrieveRelationVariableSummary ti sessionId conn),

83+ RequestHandler (\sState (RetrieveAtomFunctionSummary sessionId) -> do

84+ conn <- getConn sState

85+ handleRetrieveAtomFunctionSummary ti sessionId conn),

86+ RequestHandler (\sState (RetrieveDatabaseContextFunctionSummary sessionId) -> do

87+ conn <- getConn sState

88+ handleRetrieveDatabaseContextFunctionSummary ti sessionId conn), RequestHandler (\sState (RetrieveCurrentSchemaName sessionId) -> do

89+ conn <- getConn sState

90+ handleRetrieveCurrentSchemaName ti sessionId conn),

91+ RequestHandler (\sState (ExecuteSchemaExpr sessionId schemaExpr) -> do

92+ conn <- getConn sState

93+ handleExecuteSchemaExpr ti sessionId conn schemaExpr),

94+ RequestHandler (\sState (RetrieveSessionIsDirty sessionId) -> do

95+ conn <- getConn sState

96+ handleRetrieveSessionIsDirty ti sessionId conn),

97+ RequestHandler (\sState (ExecuteAutoMergeToHead sessionId strat headName') -> do

98+ conn <- getConn sState

99+ handleExecuteAutoMergeToHead ti sessionId conn strat headName'),

100+ RequestHandler (\sState (RetrieveTypeConstructorMapping sessionId) -> do

101+ conn <- getConn sState

102+ handleRetrieveTypeConstructorMapping ti sessionId conn),

103+ RequestHandler (\sState (ExecuteValidateMerkleHashes sessionId) -> do

104+ conn <- getConn sState

105+ handleValidateMerkleHashes ti sessionId conn)

106+ ] ++ if testFlag then testModeHandlers ti else []

107+

108+getConn :: ConnectionState ServerState -> IO Connection

109+getConn connState = do

110+ let sock = lockless (connectionSocket connState)

111+ sState = connectionServerState connState

112+ mConn <- connectionForClient sock sState

113+ case mConn of

114+ Nothing -> error "failed to find socket in client map"

115+ Just conn -> pure conn

116+

117+testModeHandlers :: Maybe Timeout -> RequestHandlers ServerState

118+testModeHandlers ti = [RequestHandler (\sState (TestTimeout sessionId) -> do

119+ conn <- getConn sState

120+ handleTestTimeout ti sessionId conn)]

121+

122+

84123-- | A notification callback which logs the notification to stderr and does nothing else.

85124loggingNotificationCallback :: NotificationCallback

86125loggingNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received \"" ++ show notName ++ "\": " ++ show evaldNot

@@ -105,9 +144,47 @@ checkFSType performCheck strat =

105144checkFSErrorMsg :: String

106145checkFSErrorMsg = "The filesystem does not support journaling so writes may not be crash-safe. Use --disable-fscheck to disable this fatal error."

107146

147+-- Sockets do not implement hashable, so we just use their string values as keys

148+type SocketString = String

149+

150+data ServerState =

151+ ServerState {

152+ --map available databases to local database configurations

153+ stateDBMap :: StmMap.Map DatabaseName Connection,

154+ --map clients to database names- after logging in, clients are afixed to specific database names

155+ stateClientMap :: StmMap.Map SocketString DatabaseName

156+ }

157+

158+-- add a client socket to the database mapping

159+addClientLogin :: DatabaseName -> ConnectionState ServerState -> IO ()

160+addClientLogin dbName cState = do

161+ let clientMap = stateClientMap (connectionServerState cState)

162+ sock = lockless (connectionSocket cState)

163+ atomically $ do

164+ mVal <- StmMap.lookup (show sock) clientMap

165+ case mVal of

166+ Nothing -> StmMap.insert dbName (show sock) clientMap

167+ Just _ -> pure () --TODO: throw exception- user already logged in

168+

169+connectionForClient :: Socket -> ServerState -> IO (Maybe Connection)

170+connectionForClient sock sState =

171+ atomically $ do

172+ mdbname <- StmMap.lookup (show sock) (stateClientMap sState)

173+ case mdbname of

174+ Nothing -> pure Nothing

175+ Just dbname ->

176+ StmMap.lookup dbname (stateDBMap sState)

177+

178+initialServerState :: DatabaseName -> Connection -> IO ServerState

179+initialServerState dbName conn =

180+ atomically $ do

181+ dbmap <- StmMap.new

182+ clientMap <- StmMap.new

183+ StmMap.insert conn dbName dbmap

184+ pure (ServerState { stateDBMap = dbmap, stateClientMap = clientMap })

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

109−launchServer :: ServerConfig -> Maybe (MVar EndPointAddress) -> IO Bool

110−launchServer daemonConfig mAddressMVar = do

186+launchServer :: ServerConfig -> Maybe (MVar SockAddr) -> IO Bool

187+launchServer daemonConfig mAddr = do

111188 checkFSResult <- checkFSType (checkFS daemonConfig) (persistenceStrategy daemonConfig)

112189 if not checkFSResult then do

113190 hPutStrLn stderr checkFSErrorMsg

@@ -120,31 +197,21 @@ launchServer daemonConfig mAddressMVar = do

120197 pure False

121198 Right conn -> do

122199 let hostname = bindHost daemonConfig

123− port = bindPort daemonConfig

124−#if MIN_VERSION_network_transport_tcp(0,7,0)

125− addrInfo = TCPAddrInfo {

126− tcpBindHost = hostname,

127− tcpBindPort = show port,

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

129− }

130− etransport <- createTransport (Addressable addrInfo) defaultTCPParameters

131−#elif MIN_VERSION_network_transport_tcp(0,6,0)

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

133−#else

134− etransport <- createTransport hostname (show port) defaultTCPParameters

135−#endif

136− case etransport of

137− Left err -> error ("failed to create transport: " ++ show err)

138− Right transport -> do

139− eEndpoint <- newEndPoint transport

140− case eEndpoint of

141− Left err -> hPutStrLn stderr ("Failed to create transport: " ++ show err) >> pure False

142− Right endpoint -> do

143− localTCPNode <- newLocalNode transport initRemoteTable

144− --traceShowM ("newLocalNode in Server " ++ show (localNodeId localTCPNode))

145− runProcess localTCPNode $ do

146− let testBool = testMode daemonConfig

147− reqTimeout = perRequestTimeout daemonConfig

148− serve (conn, databaseName daemonConfig, mAddressMVar, address endpoint) initServer (serverDefinition testBool reqTimeout)

149− liftIO $ putStrLn "serve returned"

150− pure True

200+ port = fromIntegral (bindPort daemonConfig)

201+

202+

203+ --curryer only supports IPv4 for now

204+ let addrHints = defaultHints { addrSocketType = Stream, addrFamily = AF_INET }

205+ hostAddrs <- getAddrInfo (Just addrHints) (Just hostname) Nothing

206+ case hostAddrs of

207+ [] -> hPutStrLn stderr ("Failed to resolve: " <> hostname) >> pure False

208+ (AddrInfo _ _ _ _ (SockAddrInet _ addr32) _):_ -> do

209+ let hostAddr = hostAddressToTuple addr32

210+ mTimeout = fromIntegral <$> case perRequestTimeout daemonConfig of

211+ 0 -> Nothing

212+ v -> Just v

213+

214+ sState <- initialServerState (databaseName daemonConfig) conn

215+ serve (requestHandlers (testMode daemonConfig) mTimeout) sState hostAddr port mAddr

216+ _ -> error "unsupported socket addressing mode (IPv4 only currently)"

217+

src/lib/ProjectM36/Server/Config.hs+6

@@ -12,6 +12,12 @@ data ServerConfig = ServerConfig { persistenceStrategy :: PersistenceStrategy,

1212 }

1313 deriving (Show)

1414

15+data WebsocketServerConfig = WebsocketServerConfig { wsServerConfig :: ServerConfig,

16+ tlsCertificatePath :: Maybe String,

17+ tlsKeyPath :: Maybe String

18+ }

19+ deriving (Show)

20+

1521defaultServerConfig :: ServerConfig

1622defaultServerConfig = ServerConfig { persistenceStrategy = NoPersistence,

1723 checkFS = True,

src/lib/ProjectM36/Server/EntryPoints.hs+126−153

@@ -1,173 +1,146 @@

1+{-# LANGUAGE MonoLocalBinds #-}

12module ProjectM36.Server.EntryPoints where

23import ProjectM36.Base hiding (inclusionDependencies)

34import ProjectM36.IsomorphicSchema

45import ProjectM36.Client as C

5−import ProjectM36.Error

6−import Control.Distributed.Process (Process, ProcessId)

7−import Control.Distributed.Process.ManagedProcess (ProcessReply)

8−import Control.Distributed.Process.ManagedProcess.Server (reply)

9−import Control.Distributed.Process.Async (async, task, waitCancelTimeout, AsyncResult(..))

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

116import Data.Map

127import Control.Concurrent (threadDelay)

13−import Data.Typeable

14−import Data.Binary

8+import Network.RPC.Curryer.Server

9+import System.Timeout hiding (Timeout)

10+import Network.Socket

11+import Control.Exception

1512

16−timeoutOrDie :: (Binary a, Typeable a) => Timeout -> IO a -> Process (Either ServerError a)

17−timeoutOrDie micros act =

18− if micros == 0 then

19− liftIO act >>= \x -> pure (Right x)

20− else do

21− asyncUnit <- async (task (liftIO act))

22− asyncRes <- waitCancelTimeout micros asyncUnit

23− case asyncRes of

24− AsyncDone x -> pure (Right x)

25− AsyncCancelled -> pure (Left RequestTimeoutError)

26− AsyncFailed reason -> pure (Left (ProcessDiedError (show reason)))

27− AsyncLinkFailed reason -> pure (Left (ProcessDiedError (show reason)))

28− AsyncPending -> pure (Left (ProcessDiedError "process pending"))

29−

30−type Timeout = Int

31−

32−type Reply a = Process (ProcessReply (Either ServerError a) Connection)

33−

34−handleExecuteRelationalExpr :: Timeout -> SessionId -> Connection -> RelationalExpr -> Reply (Either RelationalError Relation)

35−handleExecuteRelationalExpr ti sessionId conn expr = do

36− ret <- timeoutOrDie ti (executeRelationalExpr sessionId conn expr)

37− reply ret conn

13+timeoutOrDie :: Maybe Timeout -> IO a -> IO (Maybe a)

14+timeoutOrDie mMicros act =

15+ case mMicros of

16+ Nothing -> Just <$> act

17+ Just micros ->

18+ timeout (fromIntegral micros) act

3819

39−handleExecuteDataFrameExpr :: Timeout -> SessionId -> Connection -> DataFrameExpr -> Reply (Either RelationalError DataFrame)

40−handleExecuteDataFrameExpr ti sessionId conn expr = do

41− ret <- timeoutOrDie ti (executeDataFrameExpr sessionId conn expr)

42− reply ret conn

43−

44−handleExecuteDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Either RelationalError ())

45−handleExecuteDatabaseContextExpr ti sessionId conn dbexpr = do

46− ret <- timeoutOrDie ti (executeDatabaseContextExpr sessionId conn dbexpr)

47− reply ret conn

48−

49−handleExecuteDatabaseContextIOExpr :: Timeout -> SessionId -> Connection -> DatabaseContextIOExpr -> Reply (Either RelationalError ())

50−handleExecuteDatabaseContextIOExpr ti sessionId conn dbexpr = do

51− ret <- timeoutOrDie ti (executeDatabaseContextIOExpr sessionId conn dbexpr)

52− reply ret conn

53−

54−handleExecuteHeadName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError HeadName)

55−handleExecuteHeadName ti sessionId conn = do

56− ret <- timeoutOrDie ti (headName sessionId conn)

57− reply ret conn

58−

59−handleLogin :: Timeout -> Connection -> ProcessId -> Reply Bool

60−handleLogin ti conn newClientProcessId = do

61− ret <- timeoutOrDie ti (addClientNode conn newClientProcessId)

20+timeoutRelErr :: Maybe Timeout -> IO (Either RelationalError a) -> IO (Either RelationalError a)

21+timeoutRelErr mMicros act = do

22+ ret <- timeoutOrDie mMicros act

6223 case ret of

63− Right () -> reply (Right True) conn

64− Left err -> reply (Left err) conn

65−

66−handleExecuteGraphExpr :: Timeout -> SessionId -> Connection -> TransactionGraphOperator -> Reply (Either RelationalError ())

67−handleExecuteGraphExpr ti sessionId conn graphExpr = do

68− ret <- timeoutOrDie ti (executeGraphExpr sessionId conn graphExpr)

69− reply ret conn

70−

71−handleExecuteTransGraphRelationalExpr :: Timeout -> SessionId -> Connection -> TransGraphRelationalExpr -> Reply (Either RelationalError Relation)

72−handleExecuteTransGraphRelationalExpr ti sessionId conn graphExpr = do

73− ret <- timeoutOrDie ti (executeTransGraphRelationalExpr sessionId conn graphExpr)

74− reply ret conn

24+ Nothing -> throw TimeoutException

25+ Just v -> pure v

26+

7527

76−handleExecuteTypeForRelationalExpr :: Timeout -> SessionId -> Connection -> RelationalExpr -> Reply (Either RelationalError Relation)

77−handleExecuteTypeForRelationalExpr ti sessionId conn relExpr = do

78− ret <- timeoutOrDie ti (typeForRelationalExpr sessionId conn relExpr)

79− reply ret conn

80−

81−handleRetrieveInclusionDependencies :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError (Map IncDepName InclusionDependency))

82−handleRetrieveInclusionDependencies ti sessionId conn = do

83− ret <- timeoutOrDie ti (inclusionDependencies sessionId conn)

84− reply ret conn

85−

86−handleRetrievePlanForDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Either RelationalError GraphRefDatabaseContextExpr)

87−handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr = do

88− ret <- timeoutOrDie ti (planForDatabaseContextExpr sessionId conn dbExpr)

89− reply ret conn

90−

91−handleRetrieveTransactionGraph :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)

92−handleRetrieveTransactionGraph ti sessionId conn = do

93− ret <- timeoutOrDie ti (transactionGraphAsRelation sessionId conn)

94− reply ret conn

95−

96−handleRetrieveHeadTransactionId :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError TransactionId)

97−handleRetrieveHeadTransactionId ti sessionId conn = do

98− ret <- timeoutOrDie ti (headTransactionId sessionId conn)

99− reply ret conn

100−

101−handleCreateSessionAtCommit :: Timeout -> Connection -> TransactionId -> Reply (Either RelationalError SessionId)

102−handleCreateSessionAtCommit ti conn commitId = do

103− ret <- timeoutOrDie ti (createSessionAtCommit conn commitId)

104− reply ret conn

105−

106−handleCreateSessionAtHead :: Timeout -> Connection -> HeadName -> Reply (Either RelationalError SessionId)

107−handleCreateSessionAtHead ti conn headn = do

108− ret <- timeoutOrDie ti (createSessionAtHead conn headn)

109− reply ret conn

110−

111−handleCloseSession :: Timeout -> SessionId -> Connection -> Reply ()

112−handleCloseSession ti sessionId conn = do

113− ret <- timeoutOrDie ti (closeSession sessionId conn)

114− case ret of

115− Right () -> reply (Right ()) conn

116− Left err -> reply (Left err) conn

28+handleExecuteRelationalExpr :: Maybe Timeout -> SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)

29+handleExecuteRelationalExpr ti sessionId conn expr =

30+ timeoutRelErr ti (executeRelationalExpr sessionId conn expr)

31+

32+handleExecuteDataFrameExpr :: Maybe Timeout -> SessionId -> Connection -> DataFrameExpr -> IO (Either RelationalError DataFrame)

33+handleExecuteDataFrameExpr ti sessionId conn expr =

34+ timeoutRelErr ti (executeDataFrameExpr sessionId conn expr)

35+

36+handleExecuteDatabaseContextExpr :: Maybe Timeout -> SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError ())

37+handleExecuteDatabaseContextExpr ti sessionId conn dbexpr =

38+ timeoutRelErr ti (executeDatabaseContextExpr sessionId conn dbexpr)

39+

40+handleExecuteDatabaseContextIOExpr :: Maybe Timeout -> SessionId -> Connection -> DatabaseContextIOExpr -> IO (Either RelationalError ())

41+handleExecuteDatabaseContextIOExpr ti sessionId conn dbexpr =

42+ timeoutRelErr ti (executeDatabaseContextIOExpr sessionId conn dbexpr)

43+

44+handleExecuteHeadName :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError HeadName)

45+handleExecuteHeadName ti sessionId conn =

46+ timeoutRelErr ti (headName sessionId conn)

47+

48+handleLogin :: Connection -> Locking Socket -> IO Bool

49+handleLogin conn lockSock = do

50+ addClientNode conn lockSock

51+ pure True

52+

53+handleExecuteGraphExpr :: Maybe Timeout -> SessionId -> Connection -> TransactionGraphOperator -> IO (Either RelationalError ())

54+handleExecuteGraphExpr ti sessionId conn graphExpr =

55+ timeoutRelErr ti (executeGraphExpr sessionId conn graphExpr)

56+

57+handleExecuteTransGraphRelationalExpr :: Maybe Timeout -> SessionId -> Connection -> TransGraphRelationalExpr -> IO (Either RelationalError Relation)

58+handleExecuteTransGraphRelationalExpr ti sessionId conn graphExpr =

59+ timeoutRelErr ti (executeTransGraphRelationalExpr sessionId conn graphExpr)

60+

61+handleExecuteTypeForRelationalExpr :: Maybe Timeout -> SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)

62+handleExecuteTypeForRelationalExpr ti sessionId conn relExpr =

63+ timeoutRelErr ti (typeForRelationalExpr sessionId conn relExpr)

64+

65+handleRetrieveInclusionDependencies :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError (Map IncDepName InclusionDependency))

66+handleRetrieveInclusionDependencies ti sessionId conn =

67+ timeoutRelErr ti (inclusionDependencies sessionId conn)

68+

69+handleRetrievePlanForDatabaseContextExpr :: Maybe Timeout -> SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError GraphRefDatabaseContextExpr)

70+handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr =

71+ timeoutRelErr ti (planForDatabaseContextExpr sessionId conn dbExpr)

72+

73+handleRetrieveTransactionGraph :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation)

74+handleRetrieveTransactionGraph ti sessionId conn =

75+ timeoutRelErr ti (transactionGraphAsRelation sessionId conn)

76+

77+handleRetrieveHeadTransactionId :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError TransactionId)

78+handleRetrieveHeadTransactionId ti sessionId conn =

79+ timeoutRelErr ti (headTransactionId sessionId conn)

11780

118−handleRetrieveAtomTypesAsRelation :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)

119−handleRetrieveAtomTypesAsRelation ti sessionId conn = do

120− ret <- timeoutOrDie ti (atomTypesAsRelation sessionId conn)

121− reply ret conn

81+handleCreateSessionAtCommit :: Maybe Timeout -> Connection -> TransactionId -> IO (Either RelationalError SessionId)

82+handleCreateSessionAtCommit ti conn commitId =

83+ timeoutRelErr ti (createSessionAtCommit conn commitId)

84+

85+handleCreateSessionAtHead :: Maybe Timeout -> Connection -> HeadName -> IO (Either RelationalError SessionId)

86+handleCreateSessionAtHead ti conn headn =

87+ timeoutRelErr ti (createSessionAtHead conn headn)

88+

89+handleCloseSession :: SessionId -> Connection -> IO ()

90+handleCloseSession =

91+ closeSession

92+

93+handleRetrieveAtomTypesAsRelation :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation)

94+handleRetrieveAtomTypesAsRelation ti sessionId conn =

95+ timeoutRelErr ti (atomTypesAsRelation sessionId conn)

12296

12397-- | Returns a relation which lists the names of relvars in the current session as well as its types.

124−handleRetrieveRelationVariableSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)

125−handleRetrieveRelationVariableSummary ti sessionId conn = do

126− ret <- timeoutOrDie ti (relationVariablesAsRelation sessionId conn)

127− reply ret conn

128−

129−handleRetrieveAtomFunctionSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)

130−handleRetrieveAtomFunctionSummary ti sessionId conn = do

131− ret <- timeoutOrDie ti (atomFunctionsAsRelation sessionId conn)

132− reply ret conn

133−

134−handleRetrieveDatabaseContextFunctionSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)

135−handleRetrieveDatabaseContextFunctionSummary ti sessionId conn = do

136− ret <- timeoutOrDie ti (databaseContextFunctionsAsRelation sessionId conn)

137− reply ret conn

138−

139−handleRetrieveCurrentSchemaName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError SchemaName)

140−handleRetrieveCurrentSchemaName ti sessionId conn = do

141− ret <- timeoutOrDie ti (currentSchemaName sessionId conn)

142− reply ret conn

98+handleRetrieveRelationVariableSummary :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation)

99+handleRetrieveRelationVariableSummary ti sessionId conn =

100+ timeoutRelErr ti (relationVariablesAsRelation sessionId conn)

101+

102+handleRetrieveAtomFunctionSummary :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation)

103+handleRetrieveAtomFunctionSummary ti sessionId conn =

104+ timeoutRelErr ti (atomFunctionsAsRelation sessionId conn)

105+

106+handleRetrieveDatabaseContextFunctionSummary :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation)

107+handleRetrieveDatabaseContextFunctionSummary ti sessionId conn =

108+ timeoutRelErr ti (databaseContextFunctionsAsRelation sessionId conn)

109+

110+handleRetrieveCurrentSchemaName :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError SchemaName)

111+handleRetrieveCurrentSchemaName ti sessionId conn =

112+ timeoutRelErr ti (currentSchemaName sessionId conn)

143113

144−handleExecuteSchemaExpr :: Timeout -> SessionId -> Connection -> SchemaExpr -> Reply (Either RelationalError ())

145−handleExecuteSchemaExpr ti sessionId conn schemaExpr = do

146− ret <- timeoutOrDie ti (executeSchemaExpr sessionId conn schemaExpr)

147− reply ret conn

114+handleExecuteSchemaExpr :: Maybe Timeout -> SessionId -> Connection -> SchemaExpr -> IO (Either RelationalError ())

115+handleExecuteSchemaExpr ti sessionId conn schemaExpr =

116+ timeoutRelErr ti (executeSchemaExpr sessionId conn schemaExpr)

148117

149−handleLogout :: Timeout -> Connection -> Reply Bool

150−handleLogout _ =

118+handleLogout :: Maybe Timeout -> Connection -> IO Bool

119+handleLogout _ _ =

151120 --liftIO $ closeRemote_ conn

152− reply (pure True)

121+ pure True

153122

154−handleTestTimeout :: Timeout -> SessionId -> Connection -> Reply Bool

155−handleTestTimeout ti _ conn = do

156− ret <- timeoutOrDie ti (threadDelay 100000 >> pure True)

157− reply ret conn

123+handleTestTimeout :: Maybe Timeout -> SessionId -> Connection -> IO Bool

124+handleTestTimeout ti _ _ = do

125+ ret <- timeoutRelErr ti (threadDelay 100000 >> pure (Right ()))

126+ case ret of

127+ Right () -> pure True

128+ Left _ -> pure False

158129

159−handleRetrieveSessionIsDirty :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Bool)

160−handleRetrieveSessionIsDirty ti sessionId conn = do

161− ret <- timeoutOrDie ti (disconnectedTransactionIsDirty sessionId conn)

162− reply ret conn

163−

164−handleExecuteAutoMergeToHead :: Timeout -> SessionId -> Connection -> MergeStrategy -> HeadName -> Reply (Either RelationalError ())

165−handleExecuteAutoMergeToHead ti sessionId conn strat headName' = do

166− ret <- timeoutOrDie ti (autoMergeToHead sessionId conn strat headName')

167− reply ret conn

130+

131+

132+handleRetrieveSessionIsDirty :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Bool)

133+handleRetrieveSessionIsDirty ti sessionId conn =

134+ timeoutRelErr ti (disconnectedTransactionIsDirty sessionId conn)

135+

136+handleExecuteAutoMergeToHead :: Maybe Timeout -> SessionId -> Connection -> MergeStrategy -> HeadName -> IO (Either RelationalError ())

137+handleExecuteAutoMergeToHead ti sessionId conn strat headName' =

138+ timeoutRelErr ti (autoMergeToHead sessionId conn strat headName')

168139

169−handleRetrieveTypeConstructorMapping :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError TypeConstructorMapping)

170−handleRetrieveTypeConstructorMapping ti sessionId conn = do

171− ret <- timeoutOrDie ti (C.typeConstructorMapping sessionId conn)

172− reply ret conn

140+handleRetrieveTypeConstructorMapping :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError TypeConstructorMapping)

141+handleRetrieveTypeConstructorMapping ti sessionId conn =

142+ timeoutRelErr ti (C.typeConstructorMapping sessionId conn)

173143

144+handleValidateMerkleHashes :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError ())

145+handleValidateMerkleHashes ti sessionId conn =

146+ timeoutRelErr ti (C.validateMerkleHashes sessionId conn)

src/lib/ProjectM36/Server/ParseArgs.hs+39−16

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

33import ProjectM36.Client

44import Options.Applicative

55import ProjectM36.Server.Config

6−#if __GLASGOW_HASKELL__ <= 802

6+#if __GLASGOW_HASKELL__ < 804

77import Data.Monoid

88#endif

@@ -17,14 +17,14 @@ parseArgsWithDefaults defaults = ServerConfig <$>

1717 many parseGhcPkgPath <*>

1818 parseTimeout (perRequestTimeout defaults) <*>

1919 parseTestMode

20−

20+

2121parsePersistenceStrategy :: Parser PersistenceStrategy

2222parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>

2323 MinimalPersistence <$> dbdirOpt <|>

2424 pure NoPersistence

25− where

26− dbdirOpt = strOption (short 'd' <>

27− long "database-directory" <>

25+ where

26+ dbdirOpt = strOption (short 'd' <>

27+ long "database-directory" <>

2828 metavar "DIRECTORY" <>

2929 showDefaultWith show

3030 )

@@ -34,46 +34,69 @@ parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>

3434

3535parseTestMode :: Parser Bool

3636parseTestMode = flag True False (long "test-mode" <> hidden)

37−

38−parseCheckFS :: Parser Bool

37+

38+parseCheckFS :: Parser Bool

3939parseCheckFS = flag True False (long "disable-fscheck" <>

4040 help "Disable filesystem check for journaling.")

41−

41+

4242parseDatabaseName :: Parser DatabaseName

4343parseDatabaseName = strOption (short 'n' <>

4444 long "database" <>

4545 metavar "DATABASE_NAME")

4646

47−parseHostname :: Hostname -> Parser Hostname

47+parseHostname :: Hostname -> Parser Hostname

4848parseHostname defHostname = strOption (short 'h' <>

4949 long "hostname" <>

5050 metavar "HOST_NAME" <>

5151 value defHostname)

52−

53−parsePort :: Port -> Parser Port

52+

53+parsePort :: Port -> Parser Port

5454parsePort defPort = option auto (short 'p' <>

5555 long "port" <>

5656 metavar "PORT_NUMBER" <>

5757 value defPort)

58−

58+

5959parseGhcPkgPath :: Parser String

6060parseGhcPkgPath = strOption (long "ghc-pkg-dir" <>

6161 metavar "GHC_PACKAGE_DIRECTORY")

62−

63−parseTimeout :: Int -> Parser Int

62+

63+parseTimeout :: Int -> Parser Int

6464parseTimeout defTimeout = option auto (long "timeout" <>

6565 metavar "MICROSECONDS" <>

6666 value defTimeout)

6767

6868parseConfig :: IO ServerConfig

6969parseConfig = parseConfigWithDefaults defaultServerConfig

70−

70+

7171parseConfigWithDefaults :: ServerConfig -> IO ServerConfig

7272parseConfigWithDefaults defaults = execParser (info (parseArgsWithDefaults defaults <**> helpOption) idm)

7373

74+parseWSConfigWithDefaults :: ServerConfig -> IO WebsocketServerConfig

75+parseWSConfigWithDefaults defaults = execParser (info (parseWSArgsWithDefaults defaults <**> helpOption) idm)

76+

77+parseWSArgsWithDefaults :: ServerConfig -> Parser WebsocketServerConfig

78+parseWSArgsWithDefaults defaults = WebsocketServerConfig <$>

79+ parseArgsWithDefaults defaults <*>

80+ parseTlsCertificatePath <*>

81+ parseTlsKeyPath

82+

83+

84+parseTlsCertificatePath :: Parser (Maybe String)

85+parseTlsCertificatePath = optional $ strOption (long "tls-certificate-path" <>

86+ metavar "TLS_CERTIFICATE_PATH")

87+

88+parseTlsKeyPath :: Parser (Maybe String)

89+parseTlsKeyPath = optional $ strOption (long "tls-key-path" <>

90+ metavar "TLS_KEY_PATH")

7491

7592helpOption :: Parser (a -> a)

76−helpOption = abortOption ShowHelpText $ mconcat

93+helpOption = abortOption helpText $ mconcat

7794 [ long "help"

7895 , help "Show this help text"

7996 , hidden ]

97+ where

98+#if MIN_VERSION_optparse_applicative(0,16,0)

99+ helpText = ShowHelpText Nothing

100+#else

101+ helpText = ShowHelpText

102+#endif

src/lib/ProjectM36/Server/RemoteCallTypes.hs+67−35

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

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

1+{-# LANGUAGE DeriveGeneric, DerivingVia, CPP #-}

22module ProjectM36.Server.RemoteCallTypes where

33import ProjectM36.Base

44import ProjectM36.IsomorphicSchema

@@ -6,66 +6,98 @@ import ProjectM36.TransactionGraph

66import ProjectM36.DataFrame

77import ProjectM36.TransGraphRelationalExpression

88import ProjectM36.Session

9+import ProjectM36.Serialise.DataFrame ()

10+import ProjectM36.Serialise.IsomorphicSchema ()

911import GHC.Generics

10−import Data.Binary

11−import Control.Distributed.Process (ProcessId)

12+import Codec.Winery

13+

14+#define RPCData(typeName) deriving Generic \

15+ deriving Serialise via WineryVariant typeName

1216

1317{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}

1418-- | The initial login message. The argument should be the process id of the initiating client. This ProcessId will receive notification callbacks.

15−data Login = Login ProcessId

16− deriving (Binary, Generic)

19+data Login = Login DatabaseName

20+ RPCData(Login)

1721

1822data Logout = Logout

19− deriving (Binary, Generic)

20−data ExecuteRelationalExpr = ExecuteRelationalExpr SessionId RelationalExpr

21− deriving (Binary, Generic)

23+ RPCData(Logout)

24+

25+data ExecuteRelationalExpr = ExecuteRelationalExpr SessionId RelationalExpr

26+ RPCData(ExecuteRelationalExpr)

27+

2228data ExecuteDataFrameExpr = ExecuteDataFrameExpr SessionId DataFrameExpr

23− deriving (Binary, Generic)

29+ RPCData(ExecuteDataFrameExpr)

30+

2431data ExecuteDatabaseContextExpr = ExecuteDatabaseContextExpr SessionId DatabaseContextExpr

25− deriving (Binary, Generic)

32+ RPCData(ExecuteDatabaseContextExpr)

33+

2634data ExecuteDatabaseContextIOExpr = ExecuteDatabaseContextIOExpr SessionId DatabaseContextIOExpr

27− deriving (Binary, Generic)

35+ RPCData(ExecuteDatabaseContextIOExpr)

36+

2837data ExecuteGraphExpr = ExecuteGraphExpr SessionId TransactionGraphOperator

29− deriving (Binary, Generic)

38+ RPCData(ExecuteGraphExpr)

39+

3040data ExecuteTransGraphRelationalExpr = ExecuteTransGraphRelationalExpr SessionId TransGraphRelationalExpr

31− deriving (Binary, Generic)

41+ RPCData(ExecuteTransGraphRelationalExpr)

42+

3243data ExecuteHeadName = ExecuteHeadName SessionId

33− deriving (Binary, Generic)

44+ RPCData(ExecuteHeadName)

45+

3446data ExecuteTypeForRelationalExpr = ExecuteTypeForRelationalExpr SessionId RelationalExpr

35− deriving (Binary, Generic)

36−data ExecuteSchemaExpr = ExecuteSchemaExpr SessionId SchemaExpr

37− deriving (Binary, Generic)

47+ RPCData(ExecuteTypeForRelationalExpr)

48+

49+data ExecuteSchemaExpr = ExecuteSchemaExpr SessionId SchemaExpr RPCData(ExecuteSchemaExpr)

50+

3851data ExecuteSetCurrentSchema = ExecuteSetCurrentSchema SessionId SchemaName

39− deriving (Binary, Generic)

52+ RPCData(ExecuteSetCurrentSchema)

53+

4054data RetrieveInclusionDependencies = RetrieveInclusionDependencies SessionId

41− deriving (Binary, Generic)

55+ RPCData(RetrieveInclusionDependencies)

56+

4257data RetrievePlanForDatabaseContextExpr = RetrievePlanForDatabaseContextExpr SessionId DatabaseContextExpr

43− deriving (Binary, Generic)

58+ RPCData(RetrievePlanForDatabaseContextExpr)

59+

4460data RetrieveTransactionGraph = RetrieveTransactionGraph SessionId

45− deriving (Binary, Generic)

61+ RPCData(RetrieveTransactionGraph)

62+

4663data RetrieveHeadTransactionId = RetrieveHeadTransactionId SessionId

47− deriving (Binary, Generic)

64+ RPCData(RetrieveHeadTransactionId)

65+

4866data CreateSessionAtCommit = CreateSessionAtCommit TransactionId

49− deriving (Binary, Generic)

67+ RPCData(CreateSessionAtCommit)

68+

5069data CreateSessionAtHead = CreateSessionAtHead HeadName

51− deriving (Binary, Generic)

70+ RPCData(CreateSessionAtHead)

71+

5272data CloseSession = CloseSession SessionId

53− deriving (Binary, Generic)

73+ RPCData(CloseSession)

74+

5475data RetrieveAtomTypesAsRelation = RetrieveAtomTypesAsRelation SessionId

55− deriving (Binary, Generic)

76+ RPCData(RetrieveAtomTypesAsRelation)

77+

5678data RetrieveRelationVariableSummary = RetrieveRelationVariableSummary SessionId

57− deriving (Binary, Generic)

79+ RPCData(RetrieveRelationVariableSummary)

80+

5881data RetrieveAtomFunctionSummary = RetrieveAtomFunctionSummary SessionId

59− deriving (Binary, Generic)

82+ RPCData(RetrieveAtomFunctionSummary)

83+

6084data RetrieveDatabaseContextFunctionSummary = RetrieveDatabaseContextFunctionSummary SessionId

61− deriving (Binary, Generic)

85+ RPCData(RetrieveDatabaseContextFunctionSummary)

86+

6287data RetrieveCurrentSchemaName = RetrieveCurrentSchemaName SessionId

63− deriving (Binary, Generic)

88+ RPCData(RetrieveCurrentSchemaName)

89+

6490data TestTimeout = TestTimeout SessionId

65− deriving (Binary, Generic)

66−data RetrieveSessionIsDirty = RetrieveSessionIsDirty SessionId

67− deriving (Binary, Generic)

91+ RPCData(TestTimeout)

92+

93+data RetrieveSessionIsDirty = RetrieveSessionIsDirty SessionId

94+ RPCData(RetrieveSessionIsDirty)

95+

6896data ExecuteAutoMergeToHead = ExecuteAutoMergeToHead SessionId MergeStrategy HeadName

69− deriving (Binary, Generic)

97+ RPCData(ExecuteAutoMergeToHead)

98+

7099data RetrieveTypeConstructorMapping = RetrieveTypeConstructorMapping SessionId

71− deriving (Binary, Generic)

100+ RPCData(RetrieveTypeConstructorMapping)

101+

102+data ExecuteValidateMerkleHashes = ExecuteValidateMerkleHashes SessionId

103+ RPCData(ExecuteValidateMerkleHashes)

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

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

1414import ProjectM36.Relation

1515import ProjectM36.Error

1616import qualified Data.UUID as U

17−import qualified Control.Foldl as Foldl

1817#if MIN_VERSION_stm_containers(1,0,0)

18+import qualified Control.Foldl as Foldl

1919import qualified DeferredFolds.UnfoldlM as UF

20+#else

21+import "list-t" ListT

2022#endif

2123

2224type Sessions = StmMap.Map SessionId Session

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

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

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

4749 Attribute "parentCommit" TextAtomType]) atomMatrix

48−

49−

src/lib/ProjectM36/Shortcuts.hsnew file+247

@@ -0,0 +1,247 @@

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

2+{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE TypeApplications #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE ExtendedDefaultRules #-}

8+{-# LANGUAGE ExistentialQuantification #-}

9+{-# LANGUAGE FlexibleContexts #-}

10+{-# LANGUAGE GADTs #-}

11+{-# LANGUAGE UndecidableInstances #-}

12+module ProjectM36.Shortcuts where

13+-- users need OverloadedLabels, OverloadedLists, and default(Int,Text) to use these shortcuts.

14+import Data.Text hiding (foldl, map)

15+import ProjectM36.Base

16+import ProjectM36.Relation

17+import ProjectM36.Atomable

18+import Prelude hiding ((!!))

19+import Data.Proxy

20+import GHC.OverloadedLabels

21+import GHC.TypeLits hiding (Text)

22+import qualified Data.Text as T

23+import qualified Data.Map as M

24+import qualified Data.Set as S

25+import GHC.Exts (IsList(..))

26+import Data.Convertible

27+

28+default (Text)

29+

30+instance IsList (AttributeNamesBase ()) where

31+ type Item (AttributeNamesBase ()) = AttributeName

32+ fromList = AttributeNames . S.fromList

33+ toList (AttributeNames ns) = S.toList ns

34+ toList _ = error "needs AttributeNames"

35+

36+instance IsList (TupleExprsBase ()) where

37+ type Item TupleExprs = TupleExpr

38+ fromList ts = TupleExprs () ts

39+ toList (TupleExprs _ ts) = ts

40+

41+instance IsList TupleExpr where

42+ type Item TupleExpr = (AttributeName, AtomExpr)

43+ fromList attributeValues = TupleExpr (M.fromList attributeValues)

44+ toList (TupleExpr attributeValues) = M.toList attributeValues

45+

46+

47+-- #xxx :: Text

48+instance KnownSymbol x => IsLabel x Text where

49+ fromLabel = T.pack $ symbolVal @x Proxy

50+

51+-- #relvarName :: RelationalExpr

52+instance KnownSymbol x => IsLabel x RelationalExpr where

53+ fromLabel = RelationVariable (T.pack $ symbolVal @x Proxy) ()

54+

55+-- *Main> #a Int :: AttributeExpr

56+-- NakedAttributeExpr (Attribute "a" IntAtomType)

57+-- *Main> #a (Attr @[Int]) :: AttributeExpr

58+-- NakedAttributeExpr (Attribute "a" (ConstructedAtomType "List" (fromList [("a",IntAtomType)])))

59+-- can't offer a Relation atomtype -- don't know how to express a Relation type in haskell type. Maybe something a HList of (Text, a) ?

60+--

61+-- ps. I don't understand the usage of "AttributeAndTypeNameExpr AttributeName TypeConstructor a"

62+instance (KnownSymbol x, Atomable a)=> IsLabel x (HaskAtomType a -> AttributeExpr) where

63+ fromLabel = (NakedAttributeExpr . Attribute name) . toAtomType''

64+ where name = T.pack $ symbolVal @x Proxy

65+

66+-- (#a 1) :: ExtendTupleExpr

67+-- no need for :=

68+instance (Convertible a AtomExpr, KnownSymbol x) => IsLabel x (a -> ExtendTupleExpr) where

69+ fromLabel x = AttributeExtendTupleExpr name (convert x)

70+ where name = T.pack $ symbolVal @x Proxy

71+

72+-- #name AtomExpr

73+-- ex. tuple [ #name 3 ]

74+-- default(Text) is needed in client code to avoid `no Atomable Char`

75+instance (Convertible a AtomExpr, KnownSymbol x) => IsLabel x (a -> (AttributeName, AtomExpr)) where

76+ fromLabel = \x -> (name, convert x)

77+ where name = T.pack $ symbolVal @x Proxy

78+

79+-- *Main> #a [1] :: AtomExpr

80+-- FunctionAtomExpr "a" [NakedAtomExpr (IntegerAtom 1)] ()

81+--

82+-- This usage is not working in RestrictionPredicateExpr and AttributeExtendTupleExpr. Use f "a" [1] instead.

83+instance (KnownSymbol x, Convertible a AtomExpr) => IsLabel x ([a] -> AtomExpr) where

84+ fromLabel = \as' -> FunctionAtomExpr name (map convert as') ()

85+ where name = T.pack $ symbolVal @x Proxy

86+

87+instance (KnownSymbol x) => IsLabel x AtomExpr where

88+ fromLabel = AttributeAtomExpr name

89+ where name = T.pack $ symbolVal @x Proxy

90+

91+

92+data HaskAtomType a where

93+ Int :: HaskAtomType Int

94+ Integer :: HaskAtomType Integer

95+ Double :: HaskAtomType Double

96+ Text :: HaskAtomType Text

97+-- Day :: HaskAtomType Day

98+-- DateTime :: HaskAtomType DateTime

99+-- ByteString :: HaskAtomType ByteString

100+ Bool :: HaskAtomType Bool

101+ Attr :: Atomable a => HaskAtomType a -- a Proxy-like value for type application.

102+

103+toAtomType'' :: Atomable a => HaskAtomType a -> AtomType

104+toAtomType'' (_ :: HaskAtomType a) = toAtomType (Proxy @a)

105+

106+-- usage: relation [tuple [#a 1, #b "b"], tuple [#a 2, #b "b"]]

107+relation :: [TupleExpr] -> RelationalExpr

108+relation ts = MakeRelationFromExprs Nothing (TupleExprs () ts)

109+

110+relation' :: [AttributeExprBase ()] -> [TupleExpr] -> RelationalExpr

111+relation' as' ts = MakeRelationFromExprs (Just as') (TupleExprs () ts)

112+

113+-- usage: tuple [#name "Mike",#age 6]

114+tuple :: [(AttributeName, AtomExpr)] -> TupleExprBase ()

115+tuple as' = TupleExpr (M.fromList as')

116+

117+-- #a rename [#b `as` #c]

118+rename :: RelationalExpr -> [(AttributeName,AttributeName)] -> RelationalExpr

119+rename relExpr renameList = case renameList of

120+ [] -> Restrict TruePredicate relExpr

121+ renames ->

122+ foldl (\acc (old,new) -> Rename old new acc) relExpr renames

123+

124+--project !!

125+-- #a !! [#b,#c]

126+infix 9 !!

127+(!!) :: RelationalExpr -> AttributeNames -> RelationalExpr

128+relExpr !! xs = Project xs relExpr

129+

130+--join ><

131+-- #a >< #b

132+(><) :: RelationalExpr -> RelationalExpr -> RelationalExpr

133+a >< b = Join a b

134+

135+allBut :: AttributeNames -> AttributeNames

136+allBut (AttributeNames ns) = InvertedAttributeNames ns

137+allBut _ = error "give allBut something other than attribute names."

138+

139+allFrom :: RelationalExpr -> AttributeNames

140+allFrom = RelationalExprAttributeNames

141+

142+as :: AttributeNames -> AttributeName -> (AttributeNames, AttributeName)

143+as = (,)

144+

145+-- #a `group` ([#b,#c] `as` #d)

146+group :: RelationalExpr -> (AttributeNames, AttributeName) -> RelationalExpr

147+group relExpr (aNames, aName) = Group aNames aName relExpr

148+

149+-- #a `ungroup` #b

150+ungroup :: RelationalExpr -> AttributeName -> RelationalExpr

151+ungroup relExpr aName = Ungroup aName relExpr

152+

153+-- *Main> #a #:= true #: ( #b (f "count" [1,2]))

154+-- Assign "a" (Extend (AttributeExtendTupleExpr "b" (FunctionAtomExpr "count" [NakedAtomExpr (IntegerAtom 1),NakedAtomExpr (IntegerAtom 2)] ())) (ExistingRelation (Relation attributesFromList [] (RelationTupleSet {asList = [RelationTuple attributesFromList [] []]}))))

155+(#:) :: RelationalExpr -> ExtendTupleExpr -> RelationalExpr

156+a #: b = Extend b a

157+infix 8 #:

158+

159+instance Convertible AtomExpr AtomExpr where

160+ safeConvert n = Right n

161+

162+instance Convertible RelVarName AtomExpr where

163+ safeConvert n = Right $ RelationAtomExpr (RelationVariable n ())

164+

165+instance Convertible RelationalExpr AtomExpr where

166+ safeConvert relExpr = Right $ RelationAtomExpr relExpr

167+

168+instance Convertible RelVarName RelationalExpr where

169+ safeConvert n = Right $ RelationVariable n ()

170+

171+-- @ in tutd

172+-- (@@) "aaa"

173+(@@) :: AttributeName -> AtomExpr

174+(@@) = AttributeAtomExpr

175+

176+-- works in RestrictedPredicateExpr and AttributeExtendTupleExpr

177+-- usage: f "gte" [1]

178+f :: Convertible a AtomExpr => AtomFunctionName -> [a] -> AtomExpr

179+f n as' = FunctionAtomExpr n (map convert as') ()

180+

181+-- DatabaseContextExpr

182+-- define

183+(#::) :: RelVarName -> [AttributeExpr] -> DatabaseContextExpr

184+s #:: xs = Define s xs

185+infix 5 #::

186+

187+-- assign

188+(#:=) :: RelVarName -> RelationalExpr -> DatabaseContextExpr

189+s #:= r = Assign s r

190+infix 5 #:=

191+

192+class Boolean a b where

193+ (&&&) :: a -> b -> RestrictionPredicateExpr

194+ infixl 6 &&&

195+ (|||) :: a -> b -> RestrictionPredicateExpr

196+ infixl 5 |||

197+

198+-- where: @~ mimics the restriction symbol in algebra

199+-- usage: true #: (#a 1) @~ #a ?= 1 &&& not' false ||| (f "gte" [1])

200+(@~) :: Convertible a RestrictionPredicateExpr => RelationalExpr -> a -> RelationalExpr

201+(@~) relExpr resPreExpr = Restrict (convert resPreExpr) relExpr

202+infix 4 @~

203+

204+true :: RelationalExpr

205+true = ExistingRelation relationTrue

206+

207+false :: RelationalExpr

208+false = ExistingRelation relationFalse

209+

210+trueP :: RestrictionPredicateExprBase a

211+trueP = TruePredicate

212+

213+falseP :: RestrictionPredicateExprBase a

214+falseP = NotPredicate TruePredicate

215+

216+(?=) :: Convertible a AtomExpr => AttributeName -> a -> RestrictionPredicateExpr

217+(?=) name a = AttributeEqualityPredicate name (convert a)

218+infix 9 ?=

219+

220+not' :: Convertible a RestrictionPredicateExpr => a -> RestrictionPredicateExpr

221+not' = NotPredicate . convert

222+

223+instance (Convertible a RestrictionPredicateExpr, Convertible b RestrictionPredicateExpr) => Boolean a b where

224+ a &&& b = AndPredicate (convert a) (convert b)

225+ a ||| b = OrPredicate (convert a) (convert b)

226+

227+instance {-# Incoherent #-} Atomable a => Convertible a RestrictionPredicateExpr where

228+ safeConvert n = Right $ AtomExprPredicate $ toAtomExpr . toAtom $ n

229+

230+instance {-# Incoherent #-} Convertible RelationalExpr RestrictionPredicateExpr where

231+ safeConvert a = Right $ RelationalExprPredicate a

232+

233+instance {-# Incoherent #-} Convertible AtomExpr RestrictionPredicateExpr where

234+ safeConvert a = Right $ AtomExprPredicate a

235+

236+instance {-# Incoherent #-} Convertible RestrictionPredicateExpr RestrictionPredicateExpr where

237+ safeConvert a = Right a

238+

239+instance {-# Incoherent #-} Atomable a => Convertible a AtomExpr where

240+ safeConvert n = Right $ toAtomExpr . toAtom $ n

241+

242+toAtomExpr :: Atom -> AtomExpr

243+toAtomExpr (ConstructedAtom n _ xs) = ConstructedAtomExpr n (toAtomExpr <$> xs) ()

244+toAtomExpr a = NakedAtomExpr a

245+

246+

247+

src/lib/ProjectM36/StaticOptimizer.hs+19−19

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

1−{-# LANGUAGE TypeSynonymInstances #-}

21{-# LANGUAGE FlexibleInstances #-}

32{-# LANGUAGE FlexibleContexts #-}

43module ProjectM36.StaticOptimizer where

@@ -57,22 +56,22 @@ class Monad m => AskGraphContext m where

5756 askContext :: m DatabaseContext

5857

5958instance AskGraphContext (ReaderT GraphRefSOptDatabaseContextExprEnv (ExceptT RelationalError Identity)) where

60− askGraph = odce_graph <$> ask

61− askContext = odce_context <$> ask

59+ askGraph = asks odce_graph

60+ askContext = asks odce_context

6261

6362instance AskGraphContext (ReaderT GraphRefSOptRelationalExprEnv (ExceptT RelationalError Identity)) where

64− askGraph = ore_graph <$> ask

63+ askGraph = asks ore_graph

6564 askContext = do

66− mctx <- ore_mcontext <$> ask

65+ mctx <- asks ore_mcontext

6766 case mctx of

6867 Nothing -> throwError NoUncommittedContextInEvalError

6968 Just ctx -> pure ctx

7069

7170askTransId :: GraphRefSOptDatabaseContextExprM TransactionId

72−askTransId = odce_transId <$> ask

71+askTransId = asks odce_transId

7372

7473askMaybeContext :: GraphRefSOptRelationalExprM (Maybe DatabaseContext)

75−askMaybeContext = ore_mcontext <$> ask

74+askMaybeContext = asks ore_mcontext

7675

7776optimizeDatabaseContextExpr :: DatabaseContextExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextExpr

7877optimizeDatabaseContextExpr expr = do

@@ -81,8 +80,8 @@ optimizeDatabaseContextExpr expr = do

8180

8281optimizeAndEvalDatabaseContextExpr :: Bool -> DatabaseContextExpr -> DatabaseContextEvalMonad ()

8382optimizeAndEvalDatabaseContextExpr optimize expr = do

84− graph <- dce_graph <$> ask

85− transId <- dce_transId <$> ask

83+ graph <- asks dce_graph

84+ transId <- asks dce_transId

8685 context <- getStateContext

8786 let gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextExpr expr)

8887 eOptExpr = if optimize then

@@ -103,9 +102,9 @@ optimizeAndEvalTransGraphRelationalExpr graph tgExpr = do

103102

104103optimizeAndEvalDatabaseContextIOExpr :: DatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())

105104optimizeAndEvalDatabaseContextIOExpr expr = do

106− transId <- dbcio_transId <$> ask

105+ transId <- asks dbcio_transId

107106 ctx <- getDBCIOContext

108− graph <- dbcio_graph <$> ask

107+ graph <- asks dbcio_graph

109108 let gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextIOExpr expr)

110109 eOptExpr = runGraphRefSOptDatabaseContextExprM transId ctx graph (optimizeDatabaseContextIOExpr gfExpr)

111110 case eOptExpr of

@@ -162,8 +161,8 @@ optimizeGraphRefRelationalExpr' mctx graph expr =

162161-- | optimize relational expression within database context expr monad

163162liftGraphRefRelExpr :: GraphRefSOptRelationalExprM a -> GraphRefSOptDatabaseContextExprM a

164163liftGraphRefRelExpr m = do

165− context <- odce_context <$> ask

166− graph <- odce_graph <$> ask

164+ context <- asks odce_context

165+ graph <- asks odce_graph

167166 lift $ except $ runGraphRefSOptRelationalExprM (Just context) graph m

168167

169168fullOptimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefSOptRelationalExprM GraphRefRelationalExpr

@@ -178,7 +177,7 @@ fullOptimizeGraphRefRelationalExpr expr = do

178177optimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefSOptRelationalExprM GraphRefRelationalExpr

179178optimizeGraphRefRelationalExpr e@(MakeStaticRelation _ _) = pure e

180179

181−optimizeGraphRefRelationalExpr e@(MakeRelationFromExprs _ _) = pure e

180+optimizeGraphRefRelationalExpr e@MakeRelationFromExprs{} = pure e

182181

183182optimizeGraphRefRelationalExpr e@(ExistingRelation _) = pure e

184183

@@ -208,6 +207,8 @@ optimizeGraphRefRelationalExpr (Union exprA exprB) = do

208207 case (optExprA, optExprB) of

209208 (Restrict predA (RelationVariable nameA sA),

210209 Restrict predB (RelationVariable nameB sB)) | nameA == nameB && sA == sB -> pure (Restrict (AndPredicate predA predB) (RelationVariable nameA sA))

210+ (exprA', exprB') | isEmptyRelationExpr exprA' -> pure exprB'

211+ | isEmptyRelationExpr exprB' -> pure exprA'

211212 _ -> if optExprA == optExprB then

212213 pure optExprA

213214 else

@@ -356,10 +357,8 @@ applyStaticPredicateOptimization predi = do

356357 OrPredicate pred1 pred2 -> do

357358 optPredA <- applyStaticPredicateOptimization pred1

358359 optPredB <- applyStaticPredicateOptimization pred2

359− if optPredA == optPredB then

360+ if (optPredA == optPredB) || isTrueExpr optPredA then

360361 pure optPredA

361− else if isTrueExpr optPredA then

362− pure optPredA -- True or x -> True

363362 else if isTrueExpr optPredB then

364363 pure optPredB

365364 else

@@ -391,7 +390,7 @@ isFalseExpr _ = False

391390

392391-- determine if the created relation can statically be determined to be empty

393392isEmptyRelationExpr :: RelationalExprBase a -> Bool

394−isEmptyRelationExpr (MakeRelationFromExprs _ []) = True

393+isEmptyRelationExpr (MakeRelationFromExprs _ (TupleExprs _ [])) = True

395394isEmptyRelationExpr (MakeStaticRelation _ tupSet) = null (asList tupSet)

396395isEmptyRelationExpr (ExistingRelation rel) = rel == emptyRelationWithAttrs (attributes rel)

397396isEmptyRelationExpr _ = False

@@ -575,4 +574,5 @@ applyStaticRestrictionPushdown expr = case expr of

575574

576575-- no optimizations available

577576optimizeDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextIOExpr

578−optimizeDatabaseContextIOExpr x = pure x

577+optimizeDatabaseContextIOExpr = pure

578+

src/lib/ProjectM36/TransGraphPlanExpr.hsdeleted−5

@@ -1,5 +0,0 @@

1−module ProjectM36.TransGraphPlanExpr where

2−import ProjectM36.Base

3−-- used to create an execution plan which can potentially read from the query cache

4−

5−data TransGraphPlanExpr = ExecuteTransGraphRelationalExprPlan TransGraphRelationalExpr

src/lib/ProjectM36/TransGraphRelationalExpression.hs+9−18

@@ -10,40 +10,27 @@ import Control.Monad.Trans.Reader

1010import Control.Monad.Trans.Class

1111import Control.Monad.Trans.Except

1212import Data.Functor.Identity

13−import Data.Binary

1413

1514-- | The TransGraphRelationalExpression is equivalent to a relational expression except that relation variables can reference points in the transaction graph (at previous points in time).

1615type TransGraphRelationalExpr = RelationalExprBase TransactionIdLookup

1716

18−instance Binary TransGraphRelationalExpr

19−

2017type TransGraphAttributeNames = AttributeNamesBase TransactionIdLookup

2118

22−instance Binary TransGraphAttributeNames

23−

2419type TransGraphExtendTupleExpr = ExtendTupleExprBase TransactionIdLookup

2520

26−instance Binary TransGraphExtendTupleExpr

27−

2821type TransGraphTupleExpr = TupleExprBase TransactionIdLookup

2922

30−instance Binary TransGraphTupleExpr

23+type TransGraphTupleExprs = TupleExprsBase TransactionIdLookup

3124

3225type TransGraphRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionIdLookup

3326

34−instance Binary TransGraphRestrictionPredicateExpr

35−

3627type TransGraphAtomExpr = AtomExprBase TransactionIdLookup

3728

38−instance Binary TransGraphAtomExpr

39−

4029type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup

4130

4231type TransGraphWithNameExpr = WithNameExprBase TransactionIdLookup

4332

44−instance Binary TransGraphWithNameExpr

45−

46−data TransGraphEvalEnv = TransGraphEvalEnv {

33+newtype TransGraphEvalEnv = TransGraphEvalEnv {

4734 tge_graph :: TransactionGraph

4835 }

4936

@@ -69,7 +56,7 @@ findTrans tlook = do

6956-- OUTDATED a previous attempt at this function attempted to convert TransGraphRelationalExpr to RelationalExpr by resolving the transaction lookups. However, there is no way to resolve a FunctionAtomExpr to an Atom without fully evaluating the higher levels (TupleExpr, etc.). An anonymous function expression cannot be serialized, so that workaround is out. Still, I suspect we can reuse the existing static optimizer logic to work on both structures. The current conversion reduces the chance of whole-query optimization due to full-evaluation on top of full-evaluation, so this function would benefit from some re-design.

7057processTransGraphRelationalExpr :: TransGraphRelationalExpr -> TransGraphEvalMonad GraphRefRelationalExpr

7158processTransGraphRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

72− tupleExprs' <- mapM processTransGraphTupleExpr tupleExprs

59+ tupleExprs' <- processTransGraphTupleExprs tupleExprs

7360 case mAttrExprs of

7461 Nothing -> pure (MakeRelationFromExprs Nothing tupleExprs')

7562 Just attrExprs -> do

@@ -119,7 +106,11 @@ processTransGraphRelationalExpr (With views expr) = do

119106 ) views

120107 expr' <- processTransGraphRelationalExpr expr

121108 pure (With evaldViews expr')

122−

109+

110+processTransGraphTupleExprs :: TransGraphTupleExprs -> TransGraphEvalMonad GraphRefTupleExprs

111+processTransGraphTupleExprs (TupleExprs marker texprs) =

112+ TupleExprs <$> findTransId marker <*> mapM processTransGraphTupleExpr texprs

113+

123114processTransGraphTupleExpr :: TransGraphTupleExpr -> TransGraphEvalMonad GraphRefTupleExpr

124115processTransGraphTupleExpr (TupleExpr attrMap) = do

125116 let attrAssoc = mapM (\(attrName, atomExpr) -> do

@@ -161,7 +152,7 @@ evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr

161152 AttributeEqualityPredicate attrName <$> expr'

162153

163154processTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransGraphEvalMonad GraphRefExtendTupleExpr

164−processTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) = do

155+processTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) =

165156 AttributeExtendTupleExpr attrName <$> processTransGraphAtomExpr expr

166157

167158processTransGraphAttributeExpr :: TransGraphAttributeExpr -> TransGraphEvalMonad GraphRefAttributeExpr

src/lib/ProjectM36/Transaction.hs+10−5

@@ -17,11 +17,10 @@ singleParent tid = tid NE.:| []

1717-- | Return the same transaction but referencing only the specific child transactions. This is useful when traversing a graph and returning a subgraph. This doesn't filter parent transactions because it assumes a head-to-root traversal.

1818filterTransactionInfoTransactions :: S.Set TransactionId -> TransactionInfo -> TransactionInfo

1919filterTransactionInfoTransactions filterIds tinfo =

20− TransactionInfo { parents = case

21− NE.filter (\parent -> S.member parent filterIds) (parents tinfo) of

20+ tinfo { parents = case

21+ NE.filter (`S.member` filterIds) (parents tinfo) of

2222 [] -> rootParent

23− xs -> NE.fromList xs,

24− stamp = stamp tinfo }

23+ xs -> NE.fromList xs}

2524

2625filterParent :: TransactionId -> S.Set TransactionId -> TransactionId

2726filterParent parentId validIds = if S.member parentId validIds then parentId else U.nil

@@ -43,7 +42,13 @@ subschemas :: Transaction -> Subschemas

4342subschemas (Transaction _ _ (Schemas _ sschemas)) = sschemas

4443

4544fresh :: TransactionId -> UTCTime -> Schemas -> Transaction

46−fresh freshId stamp' newSchemas = Transaction freshId (TransactionInfo rootParent stamp') newSchemas

45+fresh freshId stamp' = Transaction freshId tinfo

46+ where

47+ tinfo = TransactionInfo {parents = rootParent,

48+ stamp = stamp',

49+ merkleHash = mempty

50+ }

4751

4852timestamp :: Transaction -> UTCTime

4953timestamp (Transaction _ tinfo _) = stamp tinfo

54+

src/lib/ProjectM36/Transaction/Persist.hs+51−31

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

1+{-# LANGUAGE TypeApplications #-}

12module ProjectM36.Transaction.Persist where

23import ProjectM36.Base

34import ProjectM36.Error

@@ -7,17 +8,19 @@ import ProjectM36.AtomFunction

78import ProjectM36.Persist (writeBSFileSync, DiskSync, renameSync)

89import qualified Data.Map as M

910import qualified Data.HashSet as HS

10−import qualified Data.Binary as B

11−--import qualified Data.ByteString as BS

1211import System.FilePath

1312import System.Directory

1413import qualified Data.Text as T

1514import Control.Monad

1615import ProjectM36.ScriptSession

1716import ProjectM36.AtomFunctions.Basic (precompiledAtomFunctions)

18−import Control.Exception

17+import Codec.Winery

18+

19+#ifdef PM36_HASKELL_SCRIPTING

1920import GHC

21+import Control.Exception

2022import GHC.Paths

23+#endif

2124

2225getDirectoryNames :: FilePath -> IO [FilePath]

2326getDirectoryNames path =

@@ -59,7 +62,7 @@ readTransaction dbdir transId mScriptSession = do

5962 return $ Left $ MissingTransactionError transId

6063 else do

6164 relvars <- readRelVars transDir

62− transInfo <- B.decodeFile (transactionInfoPath transDir)

65+ transInfo <- readFileDeserialise (transactionInfoPath transDir)

6366 incDeps <- readIncDeps transDir

6467 typeCons <- readTypeConstructorMapping transDir

6568 sschemas <- readSubschemas transDir

@@ -89,61 +92,68 @@ writeTransaction sync dbdir trans = do

8992 writeDBCFuncs sync tempTransDir (dbcFunctions context)

9093 writeTypeConstructorMapping sync tempTransDir (typeConstructorMapping context)

9194 writeSubschemas sync tempTransDir (subschemas trans)

92− B.encodeFile (transactionInfoPath tempTransDir) (transactionInfo trans)

95+ writeFileSerialise (transactionInfoPath tempTransDir) (transactionInfo trans)

9396 --move the temp directory to final location

9497 renameSync sync tempTransDir finalTransDir

9598

9699writeRelVars :: DiskSync -> FilePath -> RelationVariables -> IO ()

97100writeRelVars sync transDir relvars = do

98101 let path = relvarsPath transDir

99− writeBSFileSync sync path (B.encode relvars)

102+ writeBSFileSync sync path (serialise relvars)

100103

101104readRelVars :: FilePath -> IO RelationVariables

102−readRelVars transDir = do

103− B.decodeFile (relvarsPath transDir)

105+readRelVars transDir =

106+ readFileDeserialise (relvarsPath transDir)

104107

105108writeAtomFuncs :: DiskSync -> FilePath -> AtomFunctions -> IO ()

106109writeAtomFuncs sync transDir funcs = do

107110 let atomFuncPath = atomFuncsPath transDir

108− writeBSFileSync sync atomFuncPath (B.encode $ map (\f -> (atomFuncType f, atomFuncName f, atomFunctionScript f)) (HS.toList funcs))

111+ writeBSFileSync sync atomFuncPath (serialise $ map (\f -> (atomFuncType f, atomFuncName f, atomFunctionScript f)) (HS.toList funcs))

109112

110113--all the atom functions are in one file

111114readAtomFuncs :: FilePath -> Maybe ScriptSession -> IO AtomFunctions

112115readAtomFuncs transDir mScriptSession = do

113− atomFuncsList <- B.decodeFile (atomFuncsPath transDir)

116+ atomFuncsList <- readFileDeserialise (atomFuncsPath transDir)

114117 --only Haskell script functions can be serialized

115118 --we always return the pre-compiled functions

116119 funcs <- mapM (\(funcType, funcName, mFuncScript) -> loadAtomFunc precompiledAtomFunctions mScriptSession funcName funcType mFuncScript) atomFuncsList

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

118121

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

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

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

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

122125 Nothing -> case atomFunctionForName funcName precompiledFuncs of

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

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

125128 Right realFunc -> pure realFunc

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

127− Just funcScript ->

128− case mScriptSession of

130+ Just _funcScript ->

131+#ifdef PM36_HASKELL_SCRIPTING

132+ case _mScriptSession of

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

130134 Just scriptSession -> do

131135 --risk of GHC exception during compilation here

132136 eCompiledScript <- runGhc (Just libdir) $ do

133137 setSession (hscEnv scriptSession)

134− compileScript (atomFunctionBodyType scriptSession) funcScript

138+ compileScript (atomFunctionBodyType scriptSession) _funcScript

135139 case eCompiledScript of

136140 Left err -> throwIO err

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

138− atomFuncType = funcType,

139− atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript }

142+ atomFuncType = _funcType,

143+ atomFuncBody = AtomFunctionBody (Just _funcScript) compiledScript }

144+#else

145+ error "Haskell scripting is disabled"

146+#endif

140147

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

142149

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

151+#if !defined(PM36_HASKELL_SCRIPTING)

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

153+#else

144154readAtomFunc transDir funcName mScriptSession precompiledFuncs = do

145155 let atomFuncPath = atomFuncsPath transDir

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

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

147157 case mFuncScript of

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

149159 Nothing -> case atomFunctionForName funcName precompiledFuncs of

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

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

152162 Right realFunc -> pure realFunc

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

154− Just funcScript ->

164+ Just funcScript ->

165+

155166 case mScriptSession of

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

157168 Just scriptSession -> do

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

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

165176 atomFuncType = funcType,

166177 atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript }

178+#endif

167179

168180

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

@@ -172,7 +184,7 @@ writeDBCFuncs sync transDir funcs = mapM_ (writeDBCFunc sync transDir) (HS.toLis

172184writeDBCFunc :: DiskSync -> FilePath -> DatabaseContextFunction -> IO ()

173185writeDBCFunc sync transDir func = do

174186 let dbcFuncPath = dbcFuncsDir transDir </> T.unpack (dbcFuncName func)

175− writeBSFileSync sync dbcFuncPath (B.encode (dbcFuncType func, databaseContextFunctionScript func))

187+ writeBSFileSync sync dbcFuncPath (serialise (dbcFuncType func, databaseContextFunctionScript func))

176188

177189readDBCFuncs :: FilePath -> Maybe ScriptSession -> IO DatabaseContextFunctions

178190readDBCFuncs transDir mScriptSession = do

@@ -182,30 +194,38 @@ readDBCFuncs transDir mScriptSession = do

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

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

184196

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

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

198+#if !defined(PM36_HASKELL_SCRIPTING)

199+readDBCFunc transDir funcName _ precompiledFuncs = do

200+#else

186201readDBCFunc transDir funcName mScriptSession precompiledFuncs = do

202+#endif

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

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

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

189205 case mFuncScript of

190206 Nothing -> case databaseContextFunctionForName funcName precompiledFuncs of

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

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

193− Just funcScript ->

209+ Just _funcScript ->

210+#ifdef PM36_HASKELL_SCRIPTING

194211 case mScriptSession of

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

196213 Just scriptSession -> do

197214 eCompiledScript <- runGhc (Just libdir) $ do

198215 setSession (hscEnv scriptSession)

199− compileScript (dbcFunctionBodyType scriptSession) funcScript

216+ compileScript (dbcFunctionBodyType scriptSession) _funcScript

200217 case eCompiledScript of

201218 Left err -> throwIO err

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

203− dbcFuncType = funcType,

204− dbcFuncBody = DatabaseContextFunctionBody (Just funcScript) compiledScript}

220+ dbcFuncType = _funcType,

221+ dbcFuncBody = DatabaseContextFunctionBody (Just _funcScript) compiledScript}

222+#else

223+ error "Haskell scripting is disabled"

224+#endif

205225

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

207227writeIncDep sync transDir (incDepName, incDep) =

208− writeBSFileSync sync (incDepsDir transDir </> T.unpack incDepName) $ B.encode incDep

228+ writeBSFileSync sync (incDepsDir transDir </> T.unpack incDepName) $ serialise incDep

209229

210230writeIncDeps :: DiskSync -> FilePath -> M.Map IncDepName InclusionDependency -> IO ()

211231writeIncDeps sync transDir incdeps = mapM_ (writeIncDep sync transDir) $ M.toList incdeps

@@ -213,7 +233,7 @@ writeIncDeps sync transDir incdeps = mapM_ (writeIncDep sync transDir) $ M.toLis

213233readIncDep :: FilePath -> IncDepName -> IO (IncDepName, InclusionDependency)

214234readIncDep transDir incdepName = do

215235 let incDepPath = incDepsDir transDir </> T.unpack incdepName

216− incDepData <- B.decodeFile incDepPath

236+ incDepData <- readFileDeserialise incDepPath

217237 pure (incdepName, incDepData)

218238

219239readIncDeps :: FilePath -> IO (M.Map IncDepName InclusionDependency)

@@ -225,20 +245,20 @@ readIncDeps transDir = do

225245readSubschemas :: FilePath -> IO Subschemas

226246readSubschemas transDir = do

227247 let sschemasPath = subschemasPath transDir

228− B.decodeFile sschemasPath

248+ readFileDeserialise sschemasPath

229249

230250writeSubschemas :: DiskSync -> FilePath -> Subschemas -> IO ()

231251writeSubschemas sync transDir sschemas = do

232252 let sschemasPath = subschemasPath transDir

233− writeBSFileSync sync sschemasPath (B.encode sschemas)

253+ writeBSFileSync sync sschemasPath (serialise sschemas)

234254

235255writeTypeConstructorMapping :: DiskSync -> FilePath -> TypeConstructorMapping -> IO ()

236256writeTypeConstructorMapping sync path types = let atPath = typeConsPath path in

237− writeBSFileSync sync atPath $ B.encode types

257+ writeBSFileSync sync atPath $ serialise types

238258

239259readTypeConstructorMapping :: FilePath -> IO TypeConstructorMapping

240260readTypeConstructorMapping path = do

241261 let atPath = typeConsPath path

242− B.decodeFile atPath

262+ readFileDeserialise atPath

243263

244264

src/lib/ProjectM36/TransactionGraph.hs+166−77

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

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

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

22module ProjectM36.TransactionGraph where

33import ProjectM36.Base

44import ProjectM36.Error

@@ -9,37 +9,44 @@ import ProjectM36.TupleSet

99import ProjectM36.Tuple

1010import ProjectM36.RelationalExpression

1111import ProjectM36.TransactionGraph.Merge

12+import ProjectM36.MerkleHash

1213import qualified ProjectM36.DisconnectedTransaction as Discon

14+import qualified ProjectM36.Attribute as A

1315

16+import Codec.Winery

17+import Control.Monad.Except hiding (join)

18+import Control.Monad.Reader hiding (join)

1419import qualified Data.Vector as V

15−import qualified ProjectM36.Attribute as A

1620import qualified Data.UUID as U

1721import qualified Data.Set as S

1822import qualified Data.Map as M

1923import qualified Data.List.NonEmpty as NE

20−import Control.Monad

2124import Data.Time.Clock

2225import qualified Data.Text as T

2326import GHC.Generics

24−import Data.Binary

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

28+#if __GLASGOW_HASKELL__ < 804

29+import Data.Monoid

30+#endif

2631import Control.Arrow

2732import Data.Maybe

2833import Data.UUID.V4

29−#if __GLASGOW_HASKELL__ <= 802

30−import Data.Monoid

31−#endif

34+import qualified Data.ByteString.Lazy as BL

35+import ProjectM36.DatabaseContext as DBC

36+import Crypto.Hash.SHA256

3237

3338-- | Record a lookup for a specific transaction in the graph.

3439data TransactionIdLookup = TransactionIdLookup TransactionId |

3540 TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]

36− deriving (Show, Eq, Binary, Generic)

41+ deriving (Show, Eq, Generic)

42+ deriving Serialise via WineryVariant TransactionIdLookup

3743

3844-- | Used for git-style head backtracking such as topic~3^2.

39−data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- ^ git equivalent of ~: walk back n parents, arbitrarily choosing a parent when a choice must be made

45+data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- ^ git equivalent of ~v: walk back n parents, arbitrarily choosing a parent when a choice must be made

4046 TransactionIdHeadBranchBacktrack Int | -- ^ git equivalent of ^: walk back one parent level to the nth arbitrarily-chosen parent

4147 TransactionStampHeadBacktrack UTCTime -- ^ git equivalent of 'git-rev-list -n 1 --before X' find the first transaction which was created before the timestamp

42− deriving (Show, Eq, Binary, Generic)

48+ deriving (Show, Eq, Generic)

49+ deriving Serialise via WineryVariant TransactionIdHeadBacktrack

4350

4451

4552-- | Operators which manipulate a transaction graph and which transaction the current 'Session' is based upon.

@@ -51,13 +58,14 @@ data TransactionGraphOperator = JumpToHead HeadName |

5158 MergeTransactions MergeStrategy HeadName HeadName |

5259 Commit |

5360 Rollback

54− deriving (Eq, Show, Binary, Generic)

61+ deriving (Eq, Show, Generic)

62+ deriving Serialise via WineryVariant TransactionGraphOperator

5563

5664isCommit :: TransactionGraphOperator -> Bool

5765isCommit Commit = True

5866isCommit _ = False

5967

60−data ROTransactionGraphOperator = ShowGraph

68+data ROTransactionGraphOperator = ShowGraph | ValidateMerkleHashes

6169 deriving Show

6270

6371bootstrapTransactionGraph :: UTCTime -> TransactionId -> DatabaseContext -> TransactionGraph

@@ -66,14 +74,15 @@ bootstrapTransactionGraph stamp' freshId context = TransactionGraph bootstrapHea

6674 bootstrapHeads = M.singleton "master" freshTransaction

6775 newSchemas = Schemas context M.empty

6876 freshTransaction = fresh freshId stamp' newSchemas

69− bootstrapTransactions = S.singleton freshTransaction

77+ hashedTransaction = Transaction freshId ((transactionInfo freshTransaction) { merkleHash = calculateMerkleHash freshTransaction emptyTransactionGraph }) newSchemas

78+ bootstrapTransactions = S.singleton hashedTransaction

7079

7180-- | Create a transaction graph from a context.

7281freshTransactionGraph :: DatabaseContext -> IO (TransactionGraph, TransactionId)

7382freshTransactionGraph ctx = do

7483 now <- getCurrentTime

7584 freshId <- nextRandom

76− pure $ (bootstrapTransactionGraph now freshId ctx, freshId)

85+ pure (bootstrapTransactionGraph now freshId ctx, freshId)

7786

7887

7988emptyTransactionGraph :: TransactionGraph

@@ -106,7 +115,7 @@ rootTransactions graph = S.filter isRootTransaction (transactionsForGraph graph)

106115

107116-- the first transaction has no parent - all other do have parents- merges have two parents

108117parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

109−parentTransactions trans graph = transactionsForIds (parentIds trans) graph

118+parentTransactions trans = transactionsForIds (parentIds trans)

110119

111120childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

112121childTransactions trans graph = transactionsForIds childIds graph

@@ -124,10 +133,13 @@ addBranch stamp' newId newBranchName branchPointId graph = do

124133

125134--adds a disconnected transaction to a transaction graph at some head

126135addDisconnectedTransaction :: UTCTime -> TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

127−addDisconnectedTransaction stamp' newId headName (DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName newTrans

136+addDisconnectedTransaction stamp' newId headName (DisconnectedTransaction parentId schemas' _) graph = addTransactionToGraph headName newTrans' graph

128137 where

129− newTrans = Transaction newId (TI.singleParent parentId stamp') schemas'

130−

138+ newTrans = Transaction newId newTInfo schemas'

139+ newTInfo = TI.singleParent parentId stamp'

140+ newTrans' = Transaction newId (newTInfo { merkleHash = newHash }) schemas'

141+ newHash = calculateMerkleHash newTrans graph--lookup parents in graph to calculate

142+--LOOP

131143addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

132144addTransactionToGraph headName newTrans graph = do

133145 let parentIds' = parentIds newTrans

@@ -145,10 +157,24 @@ addTransactionToGraph headName newTrans graph = do

145157 unless (S.null childTs) (Left $ NewTransactionMayNotHaveChildrenError newId)

146158 --validate that the trasaction's id is unique

147159 when (isRight (transactionForId newId graph)) (Left (TransactionIdInUseError newId))

160+ --replace all references to UncommittedTransactionMarker to new transaction id

161+ let newTrans' = newTransUncommittedReplace newTrans

162+ updatedTransSet = S.insert newTrans' (transactionsForGraph graph)

163+ updatedHeads = M.insert headName newTrans' (transactionHeadsForGraph graph)

164+ pure (newTrans', TransactionGraph updatedHeads updatedTransSet)

165+

166+--replace all occurrences of the uncommitted context marker

167+newTransUncommittedReplace :: Transaction -> Transaction

168+newTransUncommittedReplace trans@(Transaction tid tinfo (Schemas ctx sschemas)) =

169+ Transaction tid tinfo (Schemas fixedContext sschemas)

170+ where

171+ uncommittedReplace UncommittedContextMarker = TransactionMarker tid

172+ uncommittedReplace marker = marker

173+ relvars = relationVariables (concreteDatabaseContext trans)

174+ fixedRelvars = M.map (fmap uncommittedReplace) relvars

175+ fixedContext = ctx { relationVariables = fixedRelvars }

176+

148177

149− let updatedTransSet = S.insert newTrans (transactionsForGraph graph)

150− updatedHeads = M.insert headName newTrans (transactionHeadsForGraph graph)

151− pure (newTrans, TransactionGraph updatedHeads updatedTransSet)

152178

153179validateGraph :: TransactionGraph -> Maybe [RelationalError]

154180validateGraph graph@(TransactionGraph _ transSet) = do

@@ -205,12 +231,12 @@ evalGraphOp _ _ _ graph (JumpToTransaction jumpId) = case transactionForId jumpI

205231 Left err -> Left err

206232 Right parentTrans -> Right (newTrans, graph)

207233 where

208− newTrans = DisconnectedTransaction jumpId (schemas parentTrans) NoOperation

234+ newTrans = DisconnectedTransaction jumpId (schemas parentTrans) False

209235

210236-- switch from one head to another

211237evalGraphOp _ _ _ graph (JumpToHead headName) =

212238 case transactionForHead headName graph of

213− Just newHeadTransaction -> let disconnectedTrans = DisconnectedTransaction (transactionId newHeadTransaction) (schemas newHeadTransaction) NoOperation in

239+ Just newHeadTransaction -> let disconnectedTrans = DisconnectedTransaction (transactionId newHeadTransaction) (schemas newHeadTransaction) False in

214240 Right (disconnectedTrans, graph)

215241 Nothing -> Left $ NoSuchHeadNameError headName

216242

@@ -264,7 +290,10 @@ evalGraphOp _ _ (DisconnectedTransaction parentId _ _) graph Rollback = case tra

264290 where

265291 newDiscon = Discon.freshTransaction parentId (schemas parentTransaction)

266292

267−evalGraphOp stamp' newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) graph

293+evalGraphOp stamp' newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) =

294+ runGraphRefRelationalExprM env $ mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB)

295+ where

296+ env = freshGraphRefRelationalExprEnv Nothing graph

268297

269298evalGraphOp _ _ discon graph@(TransactionGraph graphHeads transSet) (DeleteBranch branchName) = case transactionForHead branchName graph of

270299 Nothing -> Left (NoSuchHeadNameError branchName)

@@ -277,6 +306,7 @@ graphAsRelation (DisconnectedTransaction parentId _ _) graph@(TransactionGraph _

277306 mkRelationFromList attrs tupleMatrix

278307 where

279308 attrs = A.attributesFromList [Attribute "id" TextAtomType,

309+ Attribute "hash" ByteStringAtomType,

280310 Attribute "stamp" DateTimeAtomType,

281311 Attribute "parents" (RelationAtomType parentAttributes),

282312 Attribute "current" BoolAtomType,

@@ -286,6 +316,7 @@ graphAsRelation (DisconnectedTransaction parentId _ _) graph@(TransactionGraph _

286316 tupleGenerator transaction = case transactionParentsRelation transaction graph of

287317 Left err -> Left err

288318 Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),

319+ ByteStringAtom $ _unMerkleHash (merkleHash (transactionInfo transaction)),

289320 DateTimeAtom (timestamp transaction),

290321 RelationAtom parentTransRel,

291322 BoolAtom $ parentId == transactionId transaction,

@@ -313,29 +344,34 @@ evalROGraphOp discon graph ShowGraph = do

313344-}

314345

315346-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph

316−createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

317−createMergeTransaction stamp' newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do

318− let selectedTrans = validateHeadName selectedBranch graph t2

319− Transaction newId (TransactionInfo {

320− parents = NE.fromList [transactionId trans1,

321− transactionId trans2],

322− stamp = stamp' }) . schemas <$> selectedTrans

347+createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction

348+createMergeTransaction stamp' newId (SelectedBranchMergeStrategy selectedBranch) t2@(trans1, trans2) = do

349+ graph <- gfGraph

350+ selectedTrans <- validateHeadName selectedBranch graph t2

351+ pure $ addMerkleHash graph $

352+ Transaction newId (TransactionInfo {

353+ parents = NE.fromList [transactionId trans1,

354+ transactionId trans2],

355+ stamp = stamp',

356+ merkleHash = mempty }) (schemas selectedTrans)

323357

324358-- merge functions, relvars, individually

325−createMergeTransaction stamp' newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp' newId strat graph t2

359+createMergeTransaction stamp' newId strat@UnionMergeStrategy t2 =

360+ createUnionMergeTransaction stamp' newId strat t2

326361

327362-- merge function, relvars, but, on error, just take the component from the preferred branch

328−createMergeTransaction stamp' newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction stamp' newId strat graph t2

363+createMergeTransaction stamp' newId strat@(UnionPreferMergeStrategy _) t2 =

364+ createUnionMergeTransaction stamp' newId strat t2

329365

330366-- | Returns the correct Transaction for the branch name in the graph and ensures that it is one of the two transaction arguments in the tuple.

331−validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

367+validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction

332368validateHeadName headName graph (t1, t2) =

333369 case transactionForHead headName graph of

334− Nothing -> Left SelectedHeadMismatchMergeError

370+ Nothing -> throwError (MergeTransactionError SelectedHeadMismatchMergeError)

335371 Just trans -> if trans /= t1 && trans /= t2 then

336− Left SelectedHeadMismatchMergeError

372+ throwError (MergeTransactionError SelectedHeadMismatchMergeError)

337373 else

338− Right trans

374+ pure trans

339375

340376-- Algorithm: start at one transaction and work backwards up the parents. If there is a node we have not yet visited as a child, then walk that up to its head. If that branch contains the goal transaction, then we have completed a valid subgraph traversal.

341377subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph

@@ -348,7 +384,7 @@ subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans trav

348384 else do

349385 currentTransChildren <- childTransactions currentTrans' origGraph

350386 let searchChildren = S.difference (S.insert currentTrans' traverseSet) currentTransChildren

351− searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans' traverseSet)

387+ searchChild start' = pathToTransaction origGraph start' goalTrans (S.insert currentTrans' traverseSet)

352388 childSearches = map searchChild (S.toList searchChildren)

353389 errors = lefts childSearches

354390 pathsFound = rights childSearches

@@ -388,26 +424,28 @@ pathToTransaction graph currentTransaction targetTransaction accumTransSet = do

388424 else --we have some paths!

389425 Right (S.unions paths)

390426

391−mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)

392−mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) graph = do

427+mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> GraphRefRelationalExprM (DisconnectedTransaction, TransactionGraph)

428+mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) = do

429+ graph <- gfGraph

393430 let transactionForHeadErr name = case transactionForHead name graph of

394− Nothing -> Left (NoSuchHeadNameError name)

395− Just t -> Right t

396− transA <- transactionForHeadErr headNameA

397− transB <- transactionForHeadErr headNameB

398− disconParent <- transactionForId parentId graph

431+ Nothing -> throwError (NoSuchHeadNameError name)

432+ Just t -> pure t

433+ runE e = case e of

434+ Left e' -> throwError e'

435+ Right v -> pure v

436+ transA <- transactionForHeadErr headNameA

437+ transB <- transactionForHeadErr headNameB

438+ disconParent <- gfTransForId parentId

399439 let subHeads = M.filterWithKey (\k _ -> k `elem` [headNameA, headNameB]) (transactionHeadsForGraph graph)

400− subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty

401− subGraph' <- filterSubGraph subGraph subHeads

402− case createMergeTransaction stamp' newId mergeStrategy subGraph' (transA, transB) of

403− Left err -> Left (MergeTransactionError err)

404− Right mergedTrans ->

405− case headNameForTransaction disconParent graph of

406− Nothing -> Left (TransactionIsNotAHeadError parentId)

440+ subGraph <- runE $ subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty

441+ subGraph' <- runE $ filterSubGraph subGraph subHeads

442+ mergedTrans <- local (const (freshGraphRefRelationalExprEnv Nothing subGraph')) $ createMergeTransaction stamp' newId mergeStrategy (transA, transB)

443+ case headNameForTransaction disconParent graph of

444+ Nothing -> throwError (TransactionIsNotAHeadError parentId)

407445 Just headName -> do

408− (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph

446+ (newTrans, newGraph) <- runE $ addTransactionToGraph headName mergedTrans graph

409447 case checkConstraints (concreteDatabaseContext mergedTrans) newId graph of

410− Left err -> Left err

448+ Left err -> throwError err

411449 Right _ -> do

412450 let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)

413451 newDiscon = Discon.freshTransaction newId (schemas newTrans)

@@ -437,25 +475,29 @@ filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet

437475 newHeads = M.map (filterTransaction validIds) heads

438476

439477--helper function for commonalities in union merge

440−createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

441−createUnionMergeTransaction stamp' newId strategy graph (t1,t2) = do

478+createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction

479+createUnionMergeTransaction stamp' newId strategy (t1,t2) = do

442480 let contextA = concreteDatabaseContext t1

443481 contextB = concreteDatabaseContext t2

444−

482+ liftMergeE x = case x of

483+ Left e -> throwError (MergeTransactionError e)

484+ Right t -> pure t

485+

486+ graph <- gfGraph

445487 preference <- case strategy of

446488 UnionMergeStrategy -> pure PreferNeither

447489 UnionPreferMergeStrategy preferBranch ->

448490 case transactionForHead preferBranch graph of

449− Nothing -> Left (PreferredHeadMissingMergeError preferBranch)

491+ Nothing -> throwError (MergeTransactionError (PreferredHeadMissingMergeError preferBranch))

450492 Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond

451− badStrat -> Left (InvalidMergeStrategyError badStrat)

493+ badStrat -> throwError (MergeTransactionError (InvalidMergeStrategyError badStrat))

452494

453− incDeps <- unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)

495+ incDeps <- liftMergeE $ unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)

454496 relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB)

455− atomFuncs <- unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)

456− notifs <- unionMergeMaps preference (notifications contextA) (notifications contextB)

457− types <- unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)

458− dbcFuncs <- unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB)

497+ atomFuncs <- liftMergeE $ unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)

498+ notifs <- liftMergeE $ unionMergeMaps preference (notifications contextA) (notifications contextB)

499+ types <- liftMergeE $ unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)

500+ dbcFuncs <- liftMergeE $ unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB)

459501 -- TODO: add merge of subschemas

460502 let newContext = DatabaseContext {

461503 inclusionDependencies = incDeps,

@@ -466,10 +508,12 @@ createUnionMergeTransaction stamp' newId strategy graph (t1,t2) = do

466508 typeConstructorMapping = types

467509 }

468510 newSchemas = Schemas newContext (subschemas t1)

469− pure (Transaction newId (TransactionInfo {

470− parents = NE.fromList [transactionId t1,

471− transactionId t2],

472− stamp = stamp'}) newSchemas)

511+ pure $ addMerkleHash graph $

512+ Transaction newId (TransactionInfo {

513+ parents = NE.fromList [transactionId t1,

514+ transactionId t2],

515+ stamp = stamp',

516+ merkleHash = mempty }) newSchemas

473517

474518lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction

475519lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

@@ -486,15 +530,16 @@ backtrackGraph :: TransactionGraph -> TransactionId -> TransactionIdHeadBacktrac

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

487531backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do

488532 trans <- transactionForId currentTid graph

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

490− if length parentIds' < 1 then

491− Left RootTransactionTraversalError

492− else do

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

494− if steps == 1 then

495− pure (transactionId parentTrans)

496− else

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

533+

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

535+ case parentIds' of

536+ [] -> Left RootTransactionTraversalError

537+ firstParentId:_ -> do

538+ parentTrans <- transactionForId firstParentId graph

539+ if steps == 1 then

540+ pure (transactionId parentTrans)

541+ else

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

498543

499544backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do

500545 trans <- transactionForId currentTid graph

@@ -544,3 +589,47 @@ autoMergeToHead stamp' (tempBranchTransId, tempCommitTransId, mergeTransId) disc

544589 pure (discon''''', graph''''')

545590

546591

592+addMerkleHash :: TransactionGraph -> Transaction -> Transaction

593+addMerkleHash graph trans = Transaction (transactionId trans) newInfo (schemas trans)

594+ where

595+ newInfo = (transactionInfo trans) { merkleHash = calculateMerkleHash trans graph }

596+

597+-- the new hash includes the parents' ids, the current id, and the hash of the context, and the merkle hashes of the parent transactions

598+calculateMerkleHash :: Transaction -> TransactionGraph -> MerkleHash

599+calculateMerkleHash trans graph = MerkleHash $ hashlazy (BL.fromChunks [transIds,

600+ schemasBytes

601+ ] <> dbcBytes <> parentMerkleHashes)

602+ where

603+ parentMerkleHashes = BL.fromChunks $ map (_unMerkleHash . getMerkleHash) parentTranses

604+ parentTranses =

605+ case transactionsForIds (parentIds trans) graph of

606+ Left RootTransactionTraversalError -> []

607+ Left e -> error ("failed to find transaction in Merkle hash construction: " ++ show e)

608+ Right t -> S.toList t

609+ getMerkleHash t = merkleHash (transactionInfo t)

610+ transIds = serialise (transactionId trans : S.toList (parentIds trans))

611+ dbcBytes = DBC.hashBytes (concreteDatabaseContext trans)

612+ schemasBytes = serialise (subschemas trans)

613+

614+validateMerkleHash :: Transaction -> TransactionGraph -> Either MerkleValidationError ()

615+validateMerkleHash trans graph =

616+ if expectedHash /= actualHash then

617+ Left (MerkleValidationError (transactionId trans) expectedHash actualHash)

618+ else

619+ pure ()

620+ where

621+ expectedHash = merkleHash (transactionInfo trans)

622+ actualHash = calculateMerkleHash trans graph

623+

624+data MerkleValidationError = MerkleValidationError TransactionId MerkleHash MerkleHash

625+ deriving (Show, Eq, Generic)

626+

627+validateMerkleHashes :: TransactionGraph -> Either [MerkleValidationError] ()

628+validateMerkleHashes graph =

629+ if null errs then pure () else Left errs

630+ where

631+ errs = S.foldr validateTrans [] (transactionsForGraph graph)

632+ validateTrans trans acc =

633+ case validateMerkleHash trans graph of

634+ Left err -> err : acc

635+ _ -> acc

src/lib/ProjectM36/TransactionGraph/Merge.hs+19−15

@@ -2,10 +2,11 @@

22module ProjectM36.TransactionGraph.Merge where

33import ProjectM36.Base

44import ProjectM36.Error

5+import ProjectM36.RelationalExpression

6+import Control.Monad.Except hiding (join)

57import qualified Data.Set as S

68import qualified Data.Map as M

79import qualified ProjectM36.TypeConstructorDef as TCD

8−import ProjectM36.Relation

910import Control.Monad (foldM)

1011import qualified Data.HashSet as HS

1112

@@ -22,20 +23,23 @@ unionMergeMaps prefer mapA mapB = case prefer of

2223 Left StrategyViolatesComponentMergeError

2324

2425-- perform the merge even if the attributes are different- is this what we want? Obviously, we need finer-grained merge options.

25−unionMergeRelation :: MergePreference -> Relation -> Relation -> Either MergeError Relation

26−unionMergeRelation prefer relA relB = case relA `union` relB of

27− Right unionRel -> pure unionRel

28− Left (AttributeNamesMismatchError _) -> preferredRelVar

29− Left _ -> Left StrategyViolatesRelationVariableMergeError

30− where

31− preferredRelVar = case prefer of

32− PreferFirst -> Right relA

33− PreferSecond -> Right relB

34− PreferNeither -> Left StrategyViolatesRelationVariableMergeError

26+unionMergeRelation :: MergePreference -> GraphRefRelationalExpr -> GraphRefRelationalExpr -> GraphRefRelationalExprM GraphRefRelationalExpr

27+unionMergeRelation prefer relA relB = do

28+ let unioned = Union relA relB

29+ mergeErr = MergeTransactionError StrategyViolatesRelationVariableMergeError

30+ preferredRelVar =

31+ case prefer of

32+ PreferFirst -> pure relA

33+ PreferSecond -> pure relB

34+ PreferNeither -> throwError mergeErr

35+ handler AttributeNamesMismatchError{} = preferredRelVar

36+ handler _err' = throwError mergeErr

37+ --typecheck first?

38+ (evalGraphRefRelationalExpr unioned >> pure (Union relA relB)) `catchError` handler

3539

3640--try to execute unions against the relvars contents -- if a relvar only appears in one context, include it

37−unionMergeRelVars :: MergePreference -> RelationVariables -> RelationVariables -> Either MergeError RelationVariables

38−unionMergeRelVars _ relvarsA relvarsB = do

41+unionMergeRelVars :: MergePreference -> RelationVariables -> RelationVariables -> GraphRefRelationalExprM RelationVariables

42+unionMergeRelVars prefer relvarsA relvarsB = do

3943 let allNames = S.toList (S.union (M.keysSet relvarsA) (M.keysSet relvarsB))

4044 foldM (\acc name -> do

4145 mergedRel <- do

@@ -43,8 +47,8 @@ unionMergeRelVars _ relvarsA relvarsB = do

4347 lookupA = findRel relvarsA

4448 lookupB = findRel relvarsB

4549 case (lookupA, lookupB) of

46− (Just _, Just _) -> unimplemented

47− --unionMergeRelation prefer relA relB

50+ (Just relA, Just relB) ->

51+ unionMergeRelation prefer relA relB

4852 (Nothing, Just relB) -> pure relB

4953 (Just relA, Nothing) -> pure relA

5054 (Nothing, Nothing) -> error "impossible relvar naming lookup"

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

@@ -24,14 +24,14 @@ import Control.Exception.Base

2424import qualified Data.ByteString as BS

2525import qualified Data.Text.Encoding as TE

2626import Data.ByteString (ByteString)

27+#if __GLASGOW_HASKELL__ < 804

28+import Data.Monoid

29+#endif

2730import qualified Crypto.Hash.SHA256 as SHA256

2831import Control.Arrow

2932import Data.Time.Clock

3033import Data.Text.Read

3134import System.FilePath.Glob

32−#if __GLASGOW_HASKELL__ <= 802

33−import Data.Monoid

34−#endif

3535

3636type LockFileHash = ByteString

3737

src/lib/ProjectM36/TransactionInfo.hs+5−3

@@ -1,10 +1,12 @@

11module ProjectM36.TransactionInfo where

22import ProjectM36.Base

33import Data.Time.Clock

4−import Data.List.NonEmpty

4+import qualified Data.List.NonEmpty as NE

66-- | Create a TransactionInfo with just one parent transaction ID.

77singleParent :: TransactionId -> UTCTime -> TransactionInfo

88singleParent tid stamp' = TransactionInfo {

9− parents = tid :| [],

10− stamp = stamp' }

9+ parents = tid NE.:| [],

10+ stamp = stamp',

11+ merkleHash = mempty }

12+

src/lib/ProjectM36/Tuple.hs+47−33

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

11module ProjectM36.Tuple where

22import ProjectM36.Base

33import ProjectM36.Error

4−import ProjectM36.Attribute

4+import ProjectM36.Attribute as A

55import ProjectM36.Atom

66import ProjectM36.AtomType

77import ProjectM36.DataTypes.Primitive

@@ -15,19 +15,19 @@ import Control.Arrow

1515import Data.Maybe

1616

1717emptyTuple :: RelationTuple

18−emptyTuple = RelationTuple V.empty V.empty

18+emptyTuple = RelationTuple mempty mempty

1919

2020tupleSize :: RelationTuple -> Int

21−tupleSize (RelationTuple tupAttrs _) = V.length tupAttrs

21+tupleSize (RelationTuple tupAttrs _) = arity tupAttrs

2222

2323tupleAttributeNameSet :: RelationTuple -> S.Set AttributeName

24−tupleAttributeNameSet (RelationTuple tupAttrs _) = S.fromList $ V.toList $ V.map attributeName tupAttrs

24+tupleAttributeNameSet (RelationTuple tupAttrs _) = attributeNameSet tupAttrs

2525

2626tupleAttributes :: RelationTuple -> Attributes

2727tupleAttributes (RelationTuple tupAttrs _) = tupAttrs

2828

2929tupleAssocs :: RelationTuple -> [(AttributeName, Atom)]

30−tupleAssocs (RelationTuple attrVec tupVec) = V.toList $ V.map (first attributeName) (V.zip attrVec tupVec)

30+tupleAssocs (RelationTuple attrs tupVec) = V.toList $ V.map (first attributeName) (V.zip (attributesVec attrs) tupVec)

3131

3232orderedTupleAssocs :: RelationTuple -> [(AttributeName, Atom)]

3333orderedTupleAssocs tup@(RelationTuple attrVec _) = map (\attr -> (attributeName attr, atomForAttr (attributeName attr))) oAttrs

@@ -42,7 +42,7 @@ tupleAtoms :: RelationTuple -> V.Vector Atom

4242tupleAtoms (RelationTuple _ tupVec) = tupVec

4343

4444atomForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Atom

45−atomForAttributeName attrName (RelationTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) tupAttrs of

45+atomForAttributeName attrName (RelationTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) (attributesVec tupAttrs) of

4646 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))

4747 Just index -> case tupVec V.!? index of

4848 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))

@@ -59,7 +59,7 @@ vectorIndicesForAttributeNames attrNameVec attrs = if not $ V.null unknownAttrNa

5959 Right $ V.map mapper attrNameVec

6060 where

6161 unknownAttrNames = V.filter (`V.notElem` attributeNames attrs) attrNameVec

62− mapper attrName = fromMaybe (error "logic failure in vectorIndicesForAttributeNames") (V.elemIndex attrName (V.map attributeName attrs))

62+ mapper attrName = fromMaybe (error "logic failure in vectorIndicesForAttributeNames") (V.elemIndex attrName (attributeNames attrs))

6363

6464

6565relationForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Relation

@@ -86,10 +86,10 @@ mkRelationTuples attrs = map mapper

8686 mapper = mkRelationTuple attrs

8787

8888mkRelationTupleFromMap :: M.Map AttributeName Atom -> RelationTuple

89−mkRelationTupleFromMap attrMap = RelationTuple attrs (V.map (attrMap M.!) attrNames)

89+mkRelationTupleFromMap attrMap = RelationTuple (attributesFromList attrs) (V.map (attrMap M.!) (V.fromList attrNames))

9090 where

91− attrNames = V.fromList (M.keys attrMap)

92− attrs = V.map (\attrName -> Attribute attrName (atomTypeForAtom (attrMap M.! attrName))) attrNames

91+ attrNames = M.keys attrMap

92+ attrs = map (\attrName -> Attribute attrName (atomTypeForAtom (attrMap M.! attrName))) attrNames

9393

9494--return error if attribute names match but their types do not

9595singleTupleSetJoin :: Attributes -> RelationTuple -> RelationTupleSet -> Either RelationalError [RelationTuple]

@@ -120,8 +120,8 @@ singleTupleJoin joinedAttrs tup1@(RelationTuple tupAttrs1 _) tup2@(RelationTuple

120120 return $ Just $ RelationTuple joinedAttrs newVec

121121 where

122122 keysIntersection = V.map attributeName attrsIntersection

123− attrsIntersection = V.filter (`V.elem` tupAttrs1) tupAttrs2

124− newVec = V.map (findAtomForAttributeName . attributeName) joinedAttrs

123+ attrsIntersection = V.filter (`V.elem` attributesVec tupAttrs1) (attributesVec tupAttrs2)

124+ newVec = V.map (findAtomForAttributeName . attributeName) (attributesVec joinedAttrs)

125125 --search both tuples for the attribute

126126 findAtomForAttributeName attrName = head $ rights $ fmap (atomForAttributeName attrName) [tup1, tup2]

127127

@@ -138,23 +138,31 @@ vectorUnion v1 v2 = V.foldr folder v1 v2

138138tupleExtend :: RelationTuple -> RelationTuple -> RelationTuple

139139tupleExtend (RelationTuple tupAttrs1 tupVec1) (RelationTuple tupAttrs2 tupVec2) = RelationTuple newAttrs newVec

140140 where

141− newAttrs = tupAttrs1 V.++ tupAttrs2

142− newVec = tupVec1 V.++ tupVec2

141+ newAttrs = tupAttrs1 <> tupAttrs2

142+ newVec = tupVec1 <> tupVec2

143143

144144tupleAtomExtend :: AttributeName -> Atom -> RelationTuple -> RelationTuple

145145tupleAtomExtend newAttrName atom tupIn = tupleExtend tupIn newTup

146146 where

147− newTup = RelationTuple (V.singleton $ Attribute newAttrName (atomTypeForAtom atom)) (V.singleton atom)

147+ newTup = RelationTuple (A.singleton $ Attribute newAttrName (atomTypeForAtom atom)) (V.singleton atom)

148148

149−--this could be cheaper- it may not be wortwhile to update all the tuples for projection, but then the attribute management must be slightly different- perhaps the attributes should be a vector of association tuples [(name, index)]

150−tupleProject :: S.Set AttributeName -> RelationTuple -> RelationTuple

149+{-tupleProject :: S.Set AttributeName -> RelationTuple -> RelationTuple

151150tupleProject projectAttrs (RelationTuple attrs tupVec) = RelationTuple newAttrs newTupVec

152151 where

153− deleteIndices = V.findIndices (\attr -> S.notMember (attributeName attr) projectAttrs) attrs

152+ deleteIndices = V.findIndices (\attr -> S.notMember (attributeName attr) projectAttrs) (attributesVec attrs)

154153 indexDeleter = V.ifilter (\index _ -> V.notElem index deleteIndices)

155− newAttrs = indexDeleter attrs

154+ newAttrs = case A.projectionAttributesForNames projectAttrs attrs of

155+ Left err -> error (show (err, projectAttrs, attrs))

156+ Right attrs' -> attrs'

156157 newTupVec = indexDeleter tupVec

157−

158+-}

159+-- remember that the attributes order matters

160+tupleProject :: Attributes -> RelationTuple -> Either RelationalError RelationTuple

161+tupleProject projectAttrs tup = do

162+ newTupVec <- foldM (\acc attr ->

163+ V.snoc acc <$> atomForAttributeName (attributeName attr) tup

164+ ) V.empty (attributesVec projectAttrs)

165+ pure $ reorderTuple projectAttrs (RelationTuple projectAttrs newTupVec)

158166--return the attributes and atoms which are equal in both vectors

159167--semi-join

160168tupleIntersection :: RelationTuple -> RelationTuple -> RelationTuple

@@ -162,12 +170,14 @@ tupleIntersection tuple1 tuple2 = RelationTuple newAttrs newTupVec

162170 where

163171 attrs1 = tupleAttributes tuple1

164172 attrs2 = tupleAttributes tuple2

165− matchingIndices = V.findIndices (\attr -> V.elem attr attrs2 &&

166− atomForAttributeName (attributeName attr) tuple1 ==

167− atomForAttributeName (attributeName attr) tuple2

168− ) attrs1

173+ intersectAttrs = A.intersection attrs1 attrs2

174+ matchingIndices = V.findIndices (\attr -> A.member attr intersectAttrs &&

175+ atomForAttributeName (attributeName attr) tuple1 ==

176+ atomForAttributeName (attributeName attr) tuple2) (attributesVec attrs1)

169177 indexFilter = V.ifilter (\index _ -> V.elem index matchingIndices)

170− newAttrs = indexFilter attrs1

178+ newAttrs = case A.projectionAttributesForNames (A.attributeNameSet intersectAttrs) attrs1 of

179+ Left _ -> mempty

180+ Right attrs' -> attrs'

171181 newTupVec = indexFilter (tupleAtoms tuple1)

172182

173183-- | An optimized form of tuple update which updates vectors efficiently.

@@ -175,19 +185,20 @@ updateTupleWithAtoms :: M.Map AttributeName Atom -> RelationTuple -> RelationTup

175185updateTupleWithAtoms updateMap (RelationTuple attrs tupVec) = RelationTuple attrs newVec

176186 where

177187 updateKeysSet = M.keysSet updateMap

178− updateKeysIVec = V.filter (\(_,attr) -> S.member (attributeName attr) updateKeysSet) (V.indexed attrs)

188+ updateKeysIVec = V.filter (\(_,attr) -> S.member (attributeName attr) updateKeysSet) (V.indexed (attributesVec attrs))

179189 newVec = V.update tupVec updateVec

180190 updateVec = V.map (\(index, attr) -> (index, updateMap M.! attributeName attr)) updateKeysIVec

181191

182192tupleToMap :: RelationTuple -> M.Map AttributeName Atom

183193tupleToMap (RelationTuple attrs tupVec) = M.fromList assocList

184194 where

185− assocList = V.toList $ V.map (\(index, attr) -> (attributeName attr, tupVec V.! index)) (V.indexed attrs)

195+ assocList = V.toList $ V.map (\(index, attr) -> (attributeName attr, tupVec V.! index)) (V.indexed (attributesVec attrs))

186196

197+-- | Validate that the tuple has the correct attributes in the correct order

187198verifyTuple :: Attributes -> RelationTuple -> Either RelationalError RelationTuple

188−verifyTuple attrs tuple = let attrsTypes = V.map atomType attrs

199+verifyTuple attrs tuple = let attrsTypes = A.atomTypes attrs

189200 tupleTypes = V.map atomTypeForAtom (tupleAtoms tuple) in

190− if V.length attrs /= V.length tupleTypes then

201+ if A.arity attrs /= V.length tupleTypes then

191202 Left $ TupleAttributeCountMismatchError 0

192203 else do

193204 mapM_ (uncurry atomTypeVerify) (V.zip attrsTypes tupleTypes)

@@ -196,15 +207,18 @@ verifyTuple attrs tuple = let attrsTypes = V.map atomType attrs

196207--two tuples can be equal but the vectors of attributes could be out-of-order

197208--reorder if necessary- this is useful during relMogrify so that all the relation's tuples have identical atom/attribute ordering

198209reorderTuple :: Attributes -> RelationTuple -> RelationTuple

199−reorderTuple attrs tupIn = if tupleAttributes tupIn == attrs then

210+reorderTuple attrs tupIn = if attributesAndOrderEqual (tupleAttributes tupIn) attrs then

200211 tupIn

201212 else

202− RelationTuple attrs (V.map mapper attrs)

213+ RelationTuple attrs (V.map mapper (attributesVec attrs))

203214 where

204215 mapper attr = case atomForAttributeName (attributeName attr) tupIn of

205− Left err -> error ("logic bug in reorderTuple: " ++ show err)

216+ Left err -> error ("logic bug in reorderTuple: " ++ show err <> show tupIn)

206217 Right atom -> atom

207218

208219--used in Generics derivation for ADTs without named attributes

209220trimTuple :: Int -> RelationTuple -> RelationTuple

210−trimTuple index (RelationTuple attrs vals) = RelationTuple (V.drop index attrs) (V.drop index vals)

221+trimTuple index (RelationTuple attrs vals) =

222+ RelationTuple newAttrs (V.drop index vals)

223+ where

224+ newAttrs = A.drop index attrs

src/lib/ProjectM36/TupleSet.hs+7

@@ -31,3 +31,10 @@ mkTupleSet attrs tuples = verifyTupleSet attrs (RelationTupleSet tuples)

3131

3232mkTupleSetFromList :: Attributes -> [[Atom]] -> Either RelationalError RelationTupleSet

3333mkTupleSetFromList attrs atomMatrix = mkTupleSet attrs $ map (mkRelationTuple attrs . V.fromList) atomMatrix

34+

35+

36+-- | Union two tuplesets while reordering their attribute/atom mapping properly.

37+tupleSetUnion :: Attributes -> RelationTupleSet -> RelationTupleSet -> RelationTupleSet

38+tupleSetUnion targetAttrs tupSet1 tupSet2 = RelationTupleSet $ HS.toList . HS.fromList $ reorder (asList tupSet1) ++ reorder (asList tupSet2)

39+ where

40+ reorder = map (reorderTuple targetAttrs)

src/lib/ProjectM36/Tupleable.hs+113−36

@@ -4,28 +4,47 @@

44{-# LANGUAGE ScopedTypeVariables #-}

55{-# LANGUAGE TypeOperators #-}

66{-# LANGUAGE UndecidableInstances #-}

7−

8−module ProjectM36.Tupleable where

7+{-# LANGUAGE CPP #-}

9+module ProjectM36.Tupleable

10+ ( toInsertExpr

11+ , toDefineExpr

12+ , tupleAssocsEqualityPredicate

13+ , partitionByAttributes

14+ , toUpdateExpr

15+ , toDeleteExpr

16+ , validateAttributes

17+ , Tupleable(..)

18+

19+ -- * Generics

20+ , genericToTuple

21+ , genericFromTuple

22+ , genericToAttributes

23+ , TupleableG(..)

24+ -- ** Options

25+ , defaultTupleableOptions

26+ , TupleableOptions()

27+ , fieldModifier

28+ ) where

929

1030import Data.Foldable

1131import Data.List (partition)

1232import qualified Data.Map as Map

13−--import Data.Monoid

33+#if __GLASGOW_HASKELL__ < 804

34+import Data.Monoid

35+#endif

1436import Data.Proxy

1537import qualified Data.Text as T

1638import qualified Data.Vector as V

1739import GHC.Generics

1840import ProjectM36.Atomable

19−import ProjectM36.Attribute hiding (null)

41+import ProjectM36.Attribute as A hiding (null, toList)

2042import ProjectM36.Base

2143import ProjectM36.DataTypes.Primitive

2244import ProjectM36.Error

2345import ProjectM36.Tuple

2446import ProjectM36.TupleSet

2547import qualified Data.Set as S

26−#if __GLASGOW_HASKELL__ <= 802

27−import Data.Monoid

28−#endif

2948

3049{-import Data.Binary

3150import Control.DeepSeq

@@ -70,7 +89,7 @@ toInsertExpr vals rvName = do

7089

7190-- | Convert a 'Tupleable' to a create a 'Define' expression which can be used to create an empty relation variable. Use 'toInsertExpr' to insert the actual tuple data. This function is typically used with 'Data.Proxy'.

7291toDefineExpr :: forall a proxy. Tupleable a => proxy a -> RelVarName -> DatabaseContextExpr

73−toDefineExpr _ rvName = Define rvName (map NakedAttributeExpr (V.toList attrs))

92+toDefineExpr _ rvName = Define rvName (map NakedAttributeExpr (V.toList (attributesVec attrs)))

7493 where

7594 attrs = toAttributes (Proxy :: Proxy a)

7695

@@ -121,56 +140,110 @@ validateAttributes actualAttrs expectedAttrs val

121140 where

122141 nonMatchingAttrs = attributeNamesNotContained actualAttrs expectedAttrs

123142

124−

143+-- | Types that can be converted to and from 'RelationTuple'.

144+--

145+-- deriving without customization:

146+--

147+-- > data Example = Example

148+-- > { foo :: Integer

149+-- > , bar :: Text

150+-- > }

151+-- > deriving (Generic)

152+-- >

153+-- > instance Tupleable Example

154+--

155+-- deriving with customization using "ProjectM36.Tupleable.Deriving":

156+--

157+-- > data Example = Example

158+-- > { exampleFoo :: Integer

159+-- > , exampleBar :: Text

160+-- > }

161+-- > deriving stock (Generic)

162+-- > deriving (Tupleable)

163+-- > via Codec (Field (DropPrefix "example" >>> CamelCase)) Example

125164class Tupleable a where

126165 toTuple :: a -> RelationTuple

127166

128167 fromTuple :: RelationTuple -> Either RelationalError a

129168

130− toAttributes :: proxy a -> Attributes

169+ toAttributes :: Proxy a -> Attributes

131170

132171 default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple

133− toTuple v = toTupleG (from v)

172+ toTuple = genericToTuple defaultTupleableOptions

134173

135174 default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a

136− fromTuple tup = to <$> fromTupleG tup

175+ fromTuple = genericFromTuple defaultTupleableOptions

176+

177+ default toAttributes :: (Generic a, TupleableG (Rep a)) => Proxy a -> Attributes

178+ toAttributes = genericToAttributes defaultTupleableOptions

179+

180+-- | Options that influence deriving behavior.

181+newtype TupleableOptions = TupleableOptions {

182+ -- | A function that translates record field names into attribute names.

183+ fieldModifier :: T.Text -> T.Text

184+ }

185+

186+-- | The default options for deriving Tupleable instances.

187+--

188+-- These options can be customized by using record update syntax. For example,

189+--

190+-- > defaultTupleableOptions

191+-- > { fieldModifier = \fieldName ->

192+-- > case Data.Text.stripPrefix "example" fieldName of

193+-- > Nothing -> fieldName

194+-- > Just attributeName -> attributeName

195+-- > }

196+--

197+-- will result in record field names being translated into attribute names by

198+-- removing the prefix "example" from the field names.

199+defaultTupleableOptions :: TupleableOptions

200+defaultTupleableOptions = TupleableOptions {

201+ fieldModifier = id

202+ }

203+

204+genericToTuple :: (Generic a, TupleableG (Rep a)) => TupleableOptions -> a -> RelationTuple

205+genericToTuple opts v = toTupleG opts (from v)

206+

207+genericFromTuple :: (Generic a, TupleableG (Rep a)) => TupleableOptions -> RelationTuple -> Either RelationalError a

208+genericFromTuple opts tup = to <$> fromTupleG opts tup

137209

138− default toAttributes :: (Generic a, TupleableG (Rep a)) => proxy a -> Attributes

139− toAttributes _ = toAttributesG (from (undefined :: a))

210+genericToAttributes :: forall a. (Generic a, TupleableG (Rep a)) => TupleableOptions -> Proxy a -> Attributes

211+genericToAttributes opts _ = toAttributesG opts (from (undefined :: a))

140212

141213class TupleableG g where

142− toTupleG :: g a -> RelationTuple

143− toAttributesG :: g a -> Attributes

144− fromTupleG :: RelationTuple -> Either RelationalError (g a)

214+ toTupleG :: TupleableOptions -> g a -> RelationTuple

215+ toAttributesG :: TupleableOptions -> g a -> Attributes

216+ fromTupleG :: TupleableOptions -> RelationTuple -> Either RelationalError (g a)

145217 isRecordTypeG :: g a -> Bool

146218

147219--data type metadata

148220instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where

149− toTupleG (M1 v) = toTupleG v

150− toAttributesG (M1 v) = toAttributesG v

151− fromTupleG v = M1 <$> fromTupleG v

221+ toTupleG opts (M1 v) = toTupleG opts v

222+ toAttributesG opts (M1 v) = toAttributesG opts v

223+ fromTupleG opts v = M1 <$> fromTupleG opts v

152224 isRecordTypeG (M1 v) = isRecordTypeG v

153225

154226--constructor metadata

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

156− toTupleG (M1 v) = RelationTuple attrs atoms

228+ toTupleG opts (M1 v) = RelationTuple attrs atoms

157229 where

158− attrsToCheck = toAttributesG v

159− counter = V.generate (V.length attrsToCheck) id

160− attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then

230+ attrsToCheck = toAttributesG opts v

231+ counter = V.generate (arity attrsToCheck) id

232+ attrs = attributesFromList (V.toList attrsV)

233+ attrsV = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then

161234 Attribute ("attr" <> T.pack (show (num + 1))) typ

162235 else

163− attr) counter attrsToCheck

236+ attr) counter (attributesVec attrsToCheck)

164237 atoms = V.fromList (toAtomsG v)

165− toAttributesG (M1 v) = toAttributesG v

166− fromTupleG tup = M1 <$> fromTupleG tup

238+ toAttributesG opts (M1 v) = toAttributesG opts v

239+ fromTupleG opts tup = M1 <$> fromTupleG opts tup

167240 isRecordTypeG (M1 v) = isRecordTypeG v

168241

169242-- product types

170243instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where

171244 toTupleG = error "toTupleG"

172− toAttributesG ~(x :*: y) = toAttributesG x V.++ toAttributesG y --a bit of extra laziness prevents whnf so that we can use toAttributes (undefined :: Test2T Int Int) without throwing an exception

173− fromTupleG tup = (:*:) <$> fromTupleG tup <*> fromTupleG processedTuple

245+ toAttributesG opts ~(x :*: y) = toAttributesG opts x <> toAttributesG opts y --a bit of extra laziness prevents whnf so that we can use toAttributes (undefined :: Test2T Int Int) without throwing an exception

246+ fromTupleG opts tup = (:*:) <$> fromTupleG opts tup <*> fromTupleG opts processedTuple

174247 where

175248 processedTuple = if isRecordTypeG (undefined :: a x) then

176249 tup

@@ -181,18 +254,22 @@ instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where

181254--selector/record

182255instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where

183256 toTupleG = error "toTupleG"

184− toAttributesG m@(M1 v) = V.singleton (Attribute name aType)

257+ toAttributesG opts m@(M1 v) = A.singleton (Attribute modifiedName aType)

185258 where

186259 name = T.pack (selName m)

260+ modifiedName = if T.null name then

261+ name

262+ else

263+ fieldModifier opts name

187264 aType = toAtomTypeG v

188− fromTupleG tup = if null name then -- non-record type, just pull off the first tuple item

265+ fromTupleG opts tup = if null name then -- non-record type, just pull off the first tuple item

189266 M1 <$> atomv (V.head (tupleAtoms tup))

190267 else do

191− atom <- atomForAttributeName (T.pack name) tup

268+ atom <- atomForAttributeName (fieldModifier opts (T.pack name)) tup

192269 val <- atomv atom

193270 pure (M1 val)

194271 where

195− expectedAtomType = atomType (V.head (toAttributesG (undefined :: M1 S c a x)))

272+ expectedAtomType = atomType (V.head (attributesVec (toAttributesG opts (undefined :: M1 S c a x))))

196273 atomv atom = maybe (Left (AtomTypeMismatchError

197274 expectedAtomType

198275 (atomTypeForAtom atom)

@@ -203,8 +280,8 @@ instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where

203280--constructors with no arguments

204281--basically useless but orthoganal to relationTrue

205282instance TupleableG U1 where

206− toTupleG _= emptyTuple

207− toAttributesG _ = emptyAttributes

208− fromTupleG _ = pure U1

283+ toTupleG _ _ = emptyTuple

284+ toAttributesG _ _ = emptyAttributes

285+ fromTupleG _ _ = pure U1

209286 isRecordTypeG _ = False

210287

src/lib/ProjectM36/Tupleable/Deriving.hsnew file+229

@@ -0,0 +1,229 @@

1+{-# LANGUAGE ScopedTypeVariables #-}

2+{-# LANGUAGE TypeOperators #-}

3+{-# LANGUAGE KindSignatures #-}

4+{-# LANGUAGE DataKinds #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE UndecidableInstances #-}

8+-- | Newtypes for deriving Tupleable instances with customization using

9+-- @DerivingVia@.

10+--

11+-- Inspired by

12+-- [Dhall.Deriving](https://hackage.haskell.org/package/dhall-1.33.1/docs/Dhall-Deriving.html)

13+-- which in turn was inspired by Matt Parson's blog post

14+-- [Mirror Mirror: Reflection and Encoding Via](https://www.parsonsmatt.org/2020/02/04/mirror_mirror.html).

15+--

16+-- required extensions:

17+--

18+-- * DerivingVia

19+-- * DeriveGenerics

20+-- * TypeOperators (for @('<<<')@ and @('>>>')@)

21+-- * DataKinds (for types that take a string argument)

22+

23+module ProjectM36.Tupleable.Deriving

24+ ( -- * DerivingVia Newtype

25+ Codec(..)

26+

27+ -- * Type-level Options

28+ , ModifyOptions(..)

29+ , Field

30+

31+ -- * Type-level 'T.Text' -> 'T.Text' Functions

32+ , ModifyText(..)

33+ , AddPrefix

34+ , DropPrefix

35+ , AddSuffix

36+ , DropSuffix

37+ , UpperCase

38+ , LowerCase

39+ , TitleCase

40+ , CamelCase

41+ , PascalCase

42+ , SnakeCase

43+ , SpinalCase

44+ , TrainCase

45+

46+ -- * Composition

47+ , AsIs

48+ , type (<<<)

49+ , type (>>>)

50+

51+ -- * Re-Exports

52+ , Generic

53+ , module ProjectM36.Tupleable

54+ ) where

55+import Data.Maybe (fromMaybe)

56+import Data.Proxy

57+import qualified Data.Text as T

58+import Data.Text.Manipulate

59+import GHC.TypeLits

60+import GHC.Generics (Generic, Rep)

61+import ProjectM36.Tupleable

62+

63+

64+-- | A newtype wrapper to allow for easier deriving of 'Tupleable' instances

65+-- with customization.

66+--

67+-- The @tag@ type variable can be used to specify options for converting the

68+-- datatype to and from a 'RelationTuple'. For example,

69+--

70+-- > data Example = Example

71+-- > { exampleFoo :: Int

72+-- > , exampleBar :: Int

73+-- > }

74+-- > deriving stock (Generic)

75+-- > deriving (Tupleable)

76+-- > via Codec (Field (DropPrefix "example" >>> CamelCase)) Example

77+--

78+-- will derive an instance of 'Tupleable' where field names are translated into

79+-- attribute names by dropping the prefix @"example"@ and then converting the

80+-- result to camelCase. So @"exampleFoo"@ becomes @"foo"@ and @"exampleBar"@

81+-- becomes @"bar"@.

82+--

83+-- Requires the @DerivingGeneric@ and @DerivingVia@ extensions to be enabled.

84+newtype Codec tag a = Codec { unCodec :: a }

85+

86+instance (ModifyOptions tag, Generic a, TupleableG (Rep a)) => Tupleable (Codec tag a) where

87+ toTuple v = genericToTuple opts (unCodec v)

88+ where

89+ opts = modifyOptions (Proxy :: Proxy tag) defaultTupleableOptions

90+

91+ fromTuple tup = Codec <$> genericFromTuple opts tup

92+ where

93+ opts = modifyOptions (Proxy :: Proxy tag) defaultTupleableOptions

94+

95+ toAttributes _ = genericToAttributes opts (Proxy :: Proxy a)

96+ where

97+ opts = modifyOptions (Proxy :: Proxy tag) defaultTupleableOptions

98+

99+-- | Types that can be used as tags for 'Codec'.

100+class ModifyOptions a where

101+ modifyOptions :: proxy a -> TupleableOptions -> TupleableOptions

102+

103+-- | Change how record field names are translated into attribute names. For

104+-- example,

105+--

106+-- > Field SnakeCase

107+--

108+-- will translate the field name @fooBar@ into the attribute name @foo_bar@.

109+data Field a

110+

111+instance ModifyText a => ModifyOptions (Field a) where

112+ modifyOptions _ opts = opts { fieldModifier = newFieldModifier }

113+ where

114+ newFieldModifier = modifyText (Proxy :: Proxy a) . fieldModifier opts

115+

116+-- | Types that can be used in options that modify 'T.Text' such as in 'Field'.

117+class ModifyText a where

118+ modifyText :: proxy a -> T.Text -> T.Text

119+

120+-- | Add a prefix. @AddPrefix "foo"@ will transform @"bar"@ into @"foobar"@.

121+data AddPrefix (prefix :: Symbol)

122+

123+instance KnownSymbol prefix => ModifyText (AddPrefix prefix) where

124+ modifyText _ oldText = prefixText <> oldText

125+ where

126+ prefixText = T.pack (symbolVal (Proxy :: Proxy prefix))

127+

128+-- | Drop a prefix. @DropPrefix "bar"@ will transform @"foobar"@ into @"foo"@.

129+data DropPrefix (prefix :: Symbol)

130+

131+instance KnownSymbol prefix => ModifyText (DropPrefix prefix) where

132+ modifyText _ oldText = fromMaybe oldText (T.stripPrefix prefixText oldText)

133+ where

134+ prefixText = T.pack (symbolVal (Proxy :: Proxy prefix))

135+

136+-- | Add a suffix. @AddSuffix "bar"@ will transform @"foo"@ into @"foobar"@.

137+data AddSuffix (suffix :: Symbol)

138+

139+instance KnownSymbol suffix => ModifyText (AddSuffix suffix) where

140+ modifyText _ oldText = oldText <> suffixText

141+ where

142+ suffixText = T.pack (symbolVal (Proxy :: Proxy suffix))

143+

144+-- | Drop a suffix. @DropSuffix "bar"@ will transform @"foobar"@ into @"foo"@.

145+data DropSuffix (suffix :: Symbol)

146+

147+instance KnownSymbol suffix => ModifyText (DropSuffix suffix) where

148+ modifyText _ oldText = fromMaybe oldText (T.stripSuffix suffixText oldText)

149+ where

150+ suffixText = T.pack (symbolVal (Proxy :: Proxy suffix))

151+

152+-- | Convert to UPPERCASE. Will transform @"foobar"@ into @\"FOOBAR\"@.

153+data UpperCase

154+

155+instance ModifyText UpperCase where

156+ modifyText _ = T.toUpper

157+

158+-- | Convert to lowercase. Will transform @\"FOOBAR\"@ into @"foobar"@.

159+data LowerCase

160+

161+instance ModifyText LowerCase where

162+ modifyText _ = T.toLower

163+

164+-- | Convert to Title Case. Will transform @"fooBar"@ into @\"Foo Bar\"@.

165+data TitleCase

166+

167+instance ModifyText TitleCase where

168+ modifyText _ = toTitle

169+

170+-- | Convert to camelCase. Will transform @"foo_bar"@ into @"fooBar"@.

171+data CamelCase

172+

173+instance ModifyText CamelCase where

174+ modifyText _ = toCamel

175+

176+-- | Convert to PascalCase. Will transform @"foo_bar"@ into @\"FooBar\"@.

177+data PascalCase

178+

179+instance ModifyText PascalCase where

180+ modifyText _ = toPascal

181+

182+-- | Convert to snake_case. Will transform @"fooBar"@ into @"foo_bar"@.

183+data SnakeCase

184+

185+instance ModifyText SnakeCase where

186+ modifyText _ = toSnake

187+

188+-- | Convert to spinal-case. will transform @"fooBar"@ into @"foo-bar"@.

189+data SpinalCase

190+

191+instance ModifyText SpinalCase where

192+ modifyText _ = toSpinal

193+

194+-- | Convert to Train-Case. Will transform @"fooBar"@ into @\"Foo-Bar\"@.

195+data TrainCase

196+

197+instance ModifyText TrainCase where

198+ modifyText _ = toTrain

199+

200+-- | Identity option.

201+type AsIs = ()

202+

203+instance ModifyOptions () where

204+ modifyOptions _ = id

205+

206+instance ModifyText () where

207+ modifyText _ = id

208+

209+-- | Right to left composition.

210+--

211+-- Requires the @TypeOperators@ extension to be enabled.

212+data a <<< b

213+

214+instance (ModifyOptions a, ModifyOptions b) => ModifyOptions (a <<< b) where

215+ modifyOptions _ = modifyOptions (Proxy :: Proxy a) . modifyOptions (Proxy :: Proxy b)

216+

217+instance (ModifyText a, ModifyText b) => ModifyText (a <<< b) where

218+ modifyText _ = modifyText (Proxy :: Proxy a) . modifyText (Proxy :: Proxy b)

219+

220+-- | Left to right composition.

221+--

222+-- Requires the @TypeOperators@ extension to be enabled.

223+data a >>> b

224+

225+instance (ModifyOptions a, ModifyOptions b) => ModifyOptions (a >>> b) where

226+ modifyOptions _ = modifyOptions (Proxy :: Proxy b) . modifyOptions (Proxy :: Proxy a)

227+

228+instance (ModifyText a, ModifyText b) => ModifyText (a >>> b) where

229+ modifyText _ = modifyText (Proxy :: Proxy b) . modifyText (Proxy :: Proxy a)

src/lib/ProjectM36/WithNameExpr.hs+5−3

@@ -17,7 +17,7 @@ substituteWithNameMacros macros e@(RelationVariable rvname tid) =

1717 macroFilt (WithNameExpr macroName macroTid, _) = rvname == macroName && tid== macroTid in

1818 case filter macroFilt macros of

1919 [] -> e

20− (_,replacement):[] -> replacement

20+ [(_,replacement)] -> replacement

2121 _ -> error "more than one macro matched!"

2222substituteWithNameMacros macros (Project attrs expr) =

2323 Project attrs (substituteWithNameMacros macros expr)

@@ -42,9 +42,11 @@ substituteWithNameMacros macros (NotEquals exprA exprB) =

4242substituteWithNameMacros macros (Extend extendTup expr) =

4343 Extend (substituteWitNameMacrosExtendTupleExpr macros extendTup) (substituteWithNameMacros macros expr)

4444substituteWithNameMacros macros (With moreMacros expr) =

45− --collect and override existing macros and recurse

45+ --collect and update nested with exprs

4646 let newMacros = foldr macroFolder macros moreMacros

47− macroFolder (wnexpr, mexpr) acc = filter (\(w,_) -> w /= wnexpr) acc ++ [(wnexpr, mexpr)] in

47+ macroFolder (wnexpr, mexpr) acc =

48+ let subExpr = substituteWithNameMacros macros mexpr in

49+ filter (\(w,_) -> w /= wnexpr) acc ++ [(wnexpr, subExpr)] in

4850 --scan for a match- if it exists, replace it (representing a with clause at a lower level

4951 substituteWithNameMacros newMacros expr

5052

stack.ghc8.0.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-8.5

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−- deferred-folds-0.6.12

23−- rset-1.0.0

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.ghc8.10.yamlnew file+19

@@ -0,0 +1,19 @@

1+resolver: lts-17.13

2+packages:

3+ - "."

5+extra-deps:

6+ - git: https://github.com/agentm/curryer.git

7+ commit: 74ecaac619ad1165a4517d5c0f4e530493bda130

8+ - git: https://github.com/composewell/streamly.git

9+ commit: ac3af8749194f1788704dda8667d0b3807075cc2

10+ - fast-builder-0.1.2.1

11+ - rset-1.0.0

12+ - winery-1.3.2

13+ - barbies-th-0.1.8

14+ - base16-bytestring-1.0.1.0

15+

16+flags:

17+ project-m36:

18+ stack: true

19+# allow-newer: true

stack.ghc8.4.yaml → stack.ghc8.6.yamlrenamed+26−17

@@ -2,29 +2,39 @@

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

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

5−resolver: lts-12.11

5+resolver: lts-14.27

77# Local packages, usually specified by relative directory name

88packages:

9−- '.'

9+ - "."

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

1111extra-deps:

12−- data-accessor-transformers-0.2.1.7

13−- data-interval-1.2.0

14−- extended-reals-0.2.1.0

15−- gnuplot-0.5.5.3

16−- aeson-1.2.1.00

17−- distributed-process-0.7.4

18−- distributed-process-async-0.2.4.1

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

20−- distributed-process-extras-0.3.2

21−#- deferred-folds-0.9.7.1

22−- rset-1.0.0

23−- hashable-time-0.2.0.2

24−- network-transport-tcp-0.6.0

12+ - git: https://github.com/agentm/curryer.git

13+ commit: 74ecaac619ad1165a4517d5c0f4e530493bda130

14+ - git: https://github.com/composewell/streamly.git

15+ commit: ac3af8749194f1788704dda8667d0b3807075cc2

16+ - fast-builder-0.1.2.1

17+ - winery-1.3.2

18+ - barbies-2.0.2.0

19+ - barbies-th-0.1.7

20+ - extended-reals-0.2.3.0

21+ - data-interval-2.0.1

22+ - stm-containers-1.1.0.4

23+ - stm-hamt-1.2.0.4

24+ - rset-1.0.0

25+ - hashable-time-0.2.0.2

26+ - network-transport-tcp-0.6.0

27+ - megaparsec-7.0.5

28+ - prettyprinter-1.7.0

29+ - prettyprinter-ansi-terminal-1.1.2

30+ - fusion-plugin-types-0.1.0

31+ - base16-bytestring-1.0.1.0

32+ - modern-uri-0.3.4.0

33+ - cryptohash-sha256-0.11.102.0

34+ - http-types-0.12.3

2535

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

27−flags:

37+flags:

2838 project-m36:

2939 stack: true

3040

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

5060# compiler-check: newer-minor

5161

5262allow-newer: true

53−

stack.ghc8.2.yaml → stack.ghc8.8.yamlrenamed+26−15

@@ -2,27 +2,39 @@

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

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

5−resolver: lts-11.20

5+resolver: lts-16.4

77# Local packages, usually specified by relative directory name

88packages:

9−- '.'

9+ - "."

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

1111extra-deps:

12−- data-accessor-transformers-0.2.1.7

13−- data-interval-1.2.0

14−- extended-reals-0.2.1.0

15−- gnuplot-0.5.4.1

16−- text-1.2.2.1

17−- aeson-1.2.1.00

18−- distributed-process-0.7.3

19−- distributed-process-async-0.2.4.1

20−- distributed-process-client-server-0.2.3

21−- distributed-process-extras-0.3.2

22−- rset-1.0.0

12+ - git: https://github.com/agentm/curryer.git

13+ commit: 74ecaac619ad1165a4517d5c0f4e530493bda130

14+ - git: https://github.com/composewell/streamly.git

15+ commit: ac3af8749194f1788704dda8667d0b3807075cc2

16+ - fast-builder-0.1.2.1

17+ - winery-1.3.2

18+ - barbies-2.0.2.0

19+ - barbies-th-0.1.7

20+ - extended-reals-0.2.3.0

21+ - data-interval-2.0.1

22+ - stm-containers-1.1.0.4

23+ - stm-hamt-1.2.0.4

24+ - rset-1.0.0

25+ - hashable-time-0.2.0.2

26+ - network-transport-tcp-0.7.0

27+ - megaparsec-7.0.5

28+ - network-2.8.0.1

29+ - primitive-extras-0.8

30+ - primitive-unlifted-0.1.3.0

31+ - prettyprinter-1.7.0

32+ - prettyprinter-ansi-terminal-1.1.2

33+ - base16-bytestring-1.0.1.0

34+ - modern-uri-0.3.4.0

2335

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

25−flags:

37+flags:

2638 project-m36:

2739 stack: true

2840

@@ -48,4 +60,3 @@ extra-package-dbs: []

4860# compiler-check: newer-minor

4961

5062allow-newer: true

51−

test/Client/Simple.hs+1−2

@@ -9,7 +9,6 @@ import System.IO.Temp

99import System.FilePath

1010import ProjectM36.TupleSet

1111import ProjectM36.Attribute

12−import qualified Data.Vector as V

1312import qualified Data.Map as M

1413

1514main :: IO ()

@@ -59,7 +58,7 @@ testSimpleCommitFailure = TestCase $ do

5958 execute $ Assign "x" (ExistingRelation relationTrue)

6059 --cause error

6160 execute $ Assign "x" (MakeStaticRelation failAttrs emptyTupleSet)

62− let expectedErr = Left (RelError (RelationTypeMismatchError V.empty failAttrs))

61+ let expectedErr = Left (RelError (RelationTypeMismatchError mempty failAttrs))

6362 assertEqual "dbc error" expectedErr err

6463

6564-- #176 default merge couldn't handle Update

test/IsomorphicSchema.hs+1−3

@@ -13,7 +13,7 @@ import qualified Data.Map as M

1313import qualified Data.Set as S

1414

1515testList :: Test

16−testList = TestList [testIsoRename, testIsoRestrict]--, testIsoUnion, testSchemaValidation]

16+testList = TestList [testIsoRename, testIsoRestrict, testIsoUnion, testSchemaValidation]

1717

1818main :: IO ()

1919main = do

@@ -77,7 +77,6 @@ testIsoRestrict = TestCase $ do

7777 let predicate = AttributeEqualityPredicate "boss" (NakedAtomExpr (TextAtom ""))

7878 reenv = mkRelationalExprEnv DBC.empty graph

7979 bossRel <- assertEither $ runRelationalExprM reenv (evalRelationalExpr (Restrict predicate (ExistingRelation emprel)))

80− print "spam1"

8180 nonBossRel <- assertEither $ runRelationalExprM reenv (evalRelationalExpr (Restrict (NotPredicate predicate) (ExistingRelation emprel)))

8281

8382 let schemaA = mkRelationalExprEnv baseContext graph

@@ -94,7 +93,6 @@ testIsoRestrict = TestCase $ do

9493 let empResult = evalRelExpr (evalRelationalExpr empExpr)

9594 unionResult = evalRelExpr (evalRelationalExpr unionq)

9695 evalRelExpr = runRelationalExprM schemaA

97− print "spam2"

9896 assertEqual "boss/nonboss isorestrict" unionResult empResult

9997 --execute database context expr

10098 bobRel <- assertEither (mkRelationFromList empattrs [[TextAtom "Bob", TextAtom ""]])

test/Relation/Atomable.hs+52−20

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

11--Test Atomable typeclass which allows users to use existing Haskell datatypes to marshal them to and from the database as ConstructedAtoms.

2−{-# LANGUAGE DeriveGeneric, DeriveAnyClass, OverloadedStrings #-}

2+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, OverloadedStrings, TypeApplications, DerivingVia #-}

33import Test.HUnit

44import ProjectM36.Client

5−import Data.Binary

65import Control.DeepSeq

76import System.Exit

87import TutorialD.Interpreter.TestBase

@@ -13,47 +12,65 @@ import Data.Time.Calendar (fromGregorian)

1312import Data.Text

1413import qualified Data.Map as M

1514import Data.Proxy

15+import Codec.Winery

1616

1717{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}

1818data Test1T = Test1C Integer

19− deriving (Generic, Show, Eq, Binary, NFData, Atomable)

19+ deriving (Generic, Show, Eq, NFData, Atomable)

20+ deriving Serialise via WineryVariant Test1T

2021

2122data Test2T x = Test2C x

22− deriving (Show, Generic, Eq, Binary, NFData, Atomable)

23+ deriving (Show, Generic, Eq, NFData, Atomable)

24+ deriving Serialise via WineryVariant (Test2T x)

2325

2426data Test3T = Test3C Integer Integer

25− deriving (Show, Generic, Eq, Binary, NFData, Atomable)

27+ deriving (Show, Generic, Eq, NFData, Atomable)

28+ deriving Serialise via WineryVariant Test3T

2629

2730data Test4T = Test4Ca Integer |

2831 Test4Cb Integer

29− deriving (Show, Generic, Eq, Binary, NFData, Atomable)

32+ deriving (Show, Generic, Eq, NFData, Atomable)

33+ deriving Serialise via WineryVariant Test4T

3034

3135data TestListT = TestListC [Integer]

32− deriving (Show, Generic, Eq, Binary, NFData, Atomable)

36+ deriving (Show, Generic, Eq, NFData, Atomable)

37+ deriving Serialise via WineryVariant TestListT

3338

3439data TestNonEmptyT = TestNonEmptyC [Integer]

35− deriving (Show, Generic, Eq, Binary, NFData, Atomable)

40+ deriving (Show, Generic, Eq, NFData, Atomable)

41+ deriving Serialise via WineryVariant TestNonEmptyT

3642

3743data Test5T = Test5C {

3844 con1 :: Integer,

3945 con2 :: Integer

40− } deriving (Show, Generic, Eq, Binary, NFData, Atomable)

46+ } deriving (Show, Generic, Eq, NFData, Atomable)

47+ deriving Serialise via WineryRecord Test5T

4148

4249data Test6T = Test6C (Maybe Integer)

43− deriving (Show, Generic, Eq, Binary, NFData, Atomable)

50+ deriving (Show, Generic, Eq, NFData, Atomable)

51+ deriving Serialise via WineryVariant Test6T

4452

4553data Test7T = Test7C (Either Integer Integer)

46− deriving (Show, Generic, Eq, Binary, NFData, Atomable)

54+ deriving (Show, Generic, Eq, NFData, Atomable)

55+ deriving Serialise via WineryVariant Test7T

4756

4857data Test8T = Test8C Test1T

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

58+ deriving (Show, Generic, Eq, NFData, Atomable)

59+ deriving Serialise via WineryVariant Test8T

60+

61+data User = User

62+ { userFirstName :: Text

63+ , userLastName :: Text

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

65+ deriving Serialise via WineryRecord User

5066

5167data Test9_4T = Test9_4C {

5268 f9_41 :: Int,

5369 f9_42 :: Int,

5470 f9_43 :: Int,

5571 f9_44 :: Int }

56− deriving (Show, Generic, Eq, Binary, NFData, Atomable)

72+ deriving (Show, Generic, Eq, NFData, Atomable)

73+ deriving Serialise via WineryRecord Test9_4T

5774

5875data Test9_5T = Test9_5C {

5976 f9_51 :: Int,

@@ -62,17 +79,16 @@ data Test9_5T = Test9_5C {

6279 f9_54 :: Int,

6380 f9_55 :: Int

6481 }

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

82+ deriving (Show, Generic, Eq, NFData, Atomable)

83+ deriving Serialise via WineryRecord Test9_5T

6684

67−

6885main :: IO ()

6986main = do

7087 tcounts <- runTestTT testList

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

7289

7390testList :: Test

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

75−

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

7692

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

7894testBasicMarshaling :: Test

@@ -101,7 +117,7 @@ testHaskell2DB = TestCase $ do

101117 let createRelExpr = Assign "x" rel

102118

103119 rel = MakeRelationFromExprs Nothing

104− [TupleExpr (M.singleton "a1" (NakedAtomExpr atomVal))]

120+ (TupleExprs () [TupleExpr (M.singleton "a1" (NakedAtomExpr atomVal))])

105121 atomVal = toAtom exampleVal

106122 exampleVal = Test1C 10

107123 checkExecuteDatabaseContextExpr sessionId dbconn createRelExpr

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

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

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

159175

176+testSimpleList :: Test

177+testSimpleList = TestCase $ do

178+ let example = toAtom @[Integer] [1,2,3]

179+ expected = ConstructedAtom "Cons" (ConstructedAtomType "List" (M.fromList [("a",IntegerAtomType)])) [IntegerAtom 1,ConstructedAtom "Cons" (ConstructedAtomType "List" (M.fromList [("a",IntegerAtomType)])) [IntegerAtom 2,ConstructedAtom "Cons" (ConstructedAtomType "List" (M.fromList [("a",IntegerAtomType)])) [IntegerAtom 3,ConstructedAtom "Empty" (ConstructedAtomType "List" (M.fromList [("a",IntegerAtomType)])) []]]]

180+ assertEqual "simple list" expected example

181+

160182testNonEmptyInstance :: Test

161183testNonEmptyInstance = TestCase $ do

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

@@ -167,11 +189,21 @@ testNonPrimitiveValues = TestCase $ do

167189 let example = Test8C (Test1C 3)

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

169191

192+testRecordType :: Test

193+testRecordType = TestCase $ do

194+ let example = User { userFirstName = "Bob"

195+ ,userLastName = "Smith"

196+ }

197+ assertEqual "User record" example (fromAtom (toAtom example))

198+ let expected = AddTypeConstructor (ADTypeConstructorDef "User" []) [DataConstructorDef "User" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Text" TextAtomType),DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Text" TextAtomType)]]

199+

200+ assertEqual "User record to database context expr" expected (toAddTypeExpr (Proxy :: Proxy User))

201+

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

171203testManyFields :: Test

172204testManyFields = TestCase $ do

173− let example4 = Test9_4T 1 2 3 4

205+ let example4 = Test9_4C 1 2 3 4

174206 assertEqual "four fields product type" example4 (fromAtom (toAtom example4))

175207

176− let example5 = Test9_5T 1 2 3 4 5

208+ let example5 = Test9_5C 1 2 3 4 5

177209 assertEqual "five fields product type" example5 (fromAtom (toAtom example5))

test/Relation/Basic.hs+15−14

@@ -3,8 +3,6 @@ import ProjectM36.Base

33import ProjectM36.Relation

44import ProjectM36.Error

55import ProjectM36.DateExamples

6−import ProjectM36.TupleSet

7−import ProjectM36.Attribute hiding (null, attributeNames)

86import ProjectM36.DataTypes.Primitive

97import ProjectM36.RelationalExpression

108import ProjectM36.TransactionGraph

@@ -25,8 +23,8 @@ testList = TestList [testRelation "relationTrue" relationTrue, testRelation "rel

2523 testRelation "products" productsRel,

2624 testRelation "supplierProducts" supplierProductsRel,

2725 testMkRelationFromExprsBadAttrs,

28− testDuplicateAttributes,

29− testExistingRelationType

26+ testExistingRelationType,

27+ testReorderTuple

3028 ]

3129

3230main :: IO ()

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

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

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

6664 Left _ -> False

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

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

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

66+ A.atomTypeForAttributeName (A.attributeName attr) attrs) (attributesVec (attributes rel))

6967

7068simpleRel :: Relation

7169simpleRel = case mkRelation attrs tupleSet of

@@ -97,22 +95,25 @@ testMkRelationFromExprsBadAttrs = TestCase $ do

9795 let context = DBC.empty

9896 (graph,_) <- freshTransactionGraph context

9997 let reenv = mkRelationalExprEnv context graph

100− reExpr = MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "badAttr1" (PrimitiveTypeConstructor "Int" IntAtomType) ()]) [TupleExpr (M.singleton "badAttr2" (NakedAtomExpr (IntAtom 1)))]

98+ reExpr = MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "badAttr1" (PrimitiveTypeConstructor "Int" IntAtomType) ()]) (TupleExprs () [TupleExpr (M.singleton "badAttr2" (NakedAtomExpr (IntAtom 1)))])

10199 evald = runRelationalExprM reenv (evalRelationalExpr reExpr)

102100 case evald of

103101 Left err -> assertEqual "tuple type mismatch" (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "badAttr2" IntAtomType])) err

104102 Right _ -> assertFailure "expected tuple type mismatch"

105103

106−--creating an empty relation with duplicate attribute names should fail

107−testDuplicateAttributes :: Test

108−testDuplicateAttributes = TestCase $ do

109− let eRel = mkRelation attrs emptyTupleSet

110− attrs = attributesFromList [Attribute "a" IntAtomType, Attribute "a" TextAtomType]

111− assertEqual "duplicate attribute names" (Left (DuplicateAttributeNamesError (S.singleton "a"))) eRel

112−

113104testExistingRelationType :: Test

114105testExistingRelationType = TestCase $ do

115106 (graph, _) <- freshTransactionGraph dateExamples

116107 let typeResult = runRelationalExprM reenv (typeForRelationalExpr (ExistingRelation relationTrue))

117108 reenv = mkRelationalExprEnv dateExamples graph

118109 assertEqual "ExistingRelation with tuples type" (Right relationFalse) typeResult

110+

111+-- | Ensure that tuple reordering honors the

112+testReorderTuple :: Test

113+testReorderTuple = TestCase $ do

114+ let tup1 = mkRelationTuple attrs1 (V.fromList [IntAtom 4, TextAtom "test"])

115+ attrs1 = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" TextAtomType]

116+ attrs2 = A.attributesFromList [Attribute "b" TextAtomType, Attribute "a" IntAtomType]

117+ actual = reorderTuple attrs2 tup1

118+ expected = mkRelationTuple attrs2 (V.fromList [TextAtom "test", IntAtom 4])

119+ assertEqual "reorderTuple" expected actual

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

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

1+{-# LANGUAGE CPP #-}

13import ProjectM36.Base

24import ProjectM36.Relation.Show.CSV

35import ProjectM36.Relation.Parse.CSV

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

1113import Test.HUnit

1214import Data.Time.Calendar

1315import Data.Time.Clock

16+

17+#if __GLASGOW_HASKELL__ < 804

1418import Data.Monoid

19+#endif

20+

1521{-

1622import qualified Data.Text.Lazy as TL

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

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

1925import qualified Data.ByteString.Lazy as BS

2026-}

2127

22−main :: IO ()

23−main = do

24− tcounts <- runTestTT $ TestList [testCSVExport,

28+main :: IO ()

29+main = do

30+ tcounts <- runTestTT $ TestList [testCSVExport,

2531 testADTExport]

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

2733

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

3137 case res of

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

3339 Right val -> pure val

34−

35−testADTExport :: Test

40+

41+testADTExport :: Test

3642testADTExport = TestCase $ do

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

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

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

4046 case csvAsRelation attrs basicTypeConstructorMapping adtCSV of

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

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

43−

49+

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

4551testCSVExport :: Test

4652testCSVExport = TestCase $ do

4753 now <- getCurrentTime

48− testInterval <- assertEither $ pure (createInterval

49− (DateTimeAtom now)

54+ testInterval <- assertEither $ pure (createInterval

55+ (DateTimeAtom now)

5056 (DateTimeAtom (addUTCTime 86400 now))

5157 True

5258 False)

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

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

5460 Attribute "integerattr" IntegerAtomType,

5561 Attribute "dayattr" DayAtomType,

5662 Attribute "datetimeattr" DateTimeAtomType,

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

6167 ]

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

6369 relOrErr = mkRelationFromList attrs [

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

65− IntegerAtom 123,

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

71+ IntegerAtom 123,

6672 DayAtom (fromGregorian 2017 4 10),

6773 DateTimeAtom now,

6874 ByteStringAtom sampleByteString,

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

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

7177 testInterval

7278 ],

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

74− IntegerAtom 314,

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

80+ IntegerAtom 314,

7581 DayAtom (fromGregorian 1001 6 28),

7682 DateTimeAtom (addUTCTime 360 now),

77− ByteStringAtom sampleByteString,

83+ ByteStringAtom sampleByteString,

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

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

8086 testInterval

8187 ]]

82−

83− case relOrErr of

88+

89+ case relOrErr of

8490 Left err -> assertFailure $ "export relation creation failure: " ++ show err

85− Right rel ->

91+ Right rel ->

8692 case relationAsCSV rel of

8793 Left err -> assertFailure $ "export failed: " ++ show err

8894 Right csvData ->

@@ -91,4 +97,3 @@ testCSVExport = TestCase $ do

9197 case csvAsRelation attrs basicTypeConstructorMapping csvData of -- import csv data back to relation

9298 Left err -> assertFailure $ "re-import failed: " ++ show err

9399 Right rel' -> assertEqual "relation CSV comparison" rel rel'

94−

test/Relation/Tupleable.hs+187−9

@@ -1,19 +1,29 @@

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

1+{-# LANGUAGE

2+ DeriveGeneric

3+ , FlexibleInstances

4+ , FlexibleContexts

5+ , DeriveAnyClass

6+ , ScopedTypeVariables

7+ , TypeApplications

8+ , DataKinds

9+ , TypeOperators

10+ , AllowAmbiguousTypes

11+ , DerivingVia

12+ #-}

213import Test.HUnit

3−import ProjectM36.Tupleable

14+import ProjectM36.Tupleable.Deriving

415import ProjectM36.Atomable

5−import ProjectM36.Attribute

16+import ProjectM36.Attribute as A

617import ProjectM36.Error

7−import Data.Binary

818import ProjectM36.Base

919import Control.DeepSeq (NFData)

10−import GHC.Generics

1120import qualified Data.Vector as V

1221import qualified Data.Map as M

1322import qualified Data.Text as T

1423import qualified Data.Set as S

1524import System.Exit

1625import Data.Proxy

26+import Codec.Winery

1727

1828{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}

1929

@@ -21,35 +31,43 @@ data Test1T = Test1C {

2131 attrA :: Integer

2232 }

2333 deriving (Generic, Eq, Show)

34+ deriving Serialise via WineryRecord Test1T

2435

2536data Test2T = Test2C {

2637 attrB :: Integer,

2738 attrC :: Integer

2839 }

2940 deriving (Generic, Eq, Show)

41+ deriving Serialise via WineryRecord Test2T

3042

3143data Test3T = Test3C Integer

3244 deriving (Generic, Eq, Show)

45+ deriving Serialise via WineryVariant Test3T

3346

3447data Test4T = Test4C

3548 deriving (Generic, Eq, Show)

49+ deriving Serialise via WineryVariant Test4T

3650

3751data Test5T = Test5C1 Integer |

3852 Test5C2 Integer

3953 deriving (Generic, Eq, Show)

54+ deriving Serialise via WineryVariant Test5T

4055

4156data Test6T = Test6C T.Text Integer Double

4257 deriving (Generic, Eq, Show)

4358

4459data Test7A = Test7AC Integer

45− deriving (Generic, Show, Eq, Binary, NFData, Atomable)

60+ deriving (Generic, Show, Eq, NFData, Atomable)

61+ deriving Serialise via WineryVariant Test7A

4662

4763

4864data Test7T = Test7C Test7A

4965 deriving (Generic, Show, Eq)

66+ deriving Serialise via WineryVariant Test7T

5067

5168data Test8T = Test8C

5269 deriving (Generic, Show, Eq)

70+ deriving Serialise via WineryVariant Test8T

5371

5472data Test9T = Test9C

5573 {

@@ -58,6 +76,15 @@ data Test9T = Test9C

5876 attr9C :: Double

5977 }

6078 deriving (Generic, Show, Eq)

79+ deriving Serialise via WineryRecord Test9T

80+

81+data Test10T = Test10C {

82+ longAttrNameA10 :: Integer,

83+ long_attr_name_b10 :: Integer,

84+ longMixed_attr_NameC10 :: Integer

85+ }

86+ deriving (Generic, Show, Eq)

87+ deriving Serialise via WineryRecord Test10T

6188

6289instance Tupleable Test1T

6390

@@ -83,7 +110,7 @@ main = do

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

84111

85112testList :: Test

86−testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8, testInsertExpr, testDefineExpr, testUpdateExpr, testUpdateExprEmptyAttrs, testDeleteExpr, testUpdateExprWrongAttr, testReorderedTuple]

113+testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8 ,testInsertExpr, testDefineExpr, testUpdateExpr, testUpdateExprEmptyAttrs, testDeleteExpr, testUpdateExprWrongAttr, testReorderedTuple, testAddPrefixField, testDropPrefixField, testAddSuffixField, testDropSuffixField, testUpperCaseField, testLowerCaseField, testTitleCaseField, testCamelCaseField, testPascalCaseField, testSnakeCaseField, testSpinalCaseField, testTrainCaseField, testAsIsCodec, testAsIsField, testComposeRLCodec, testComposeRLField, testComposeLRCodec, testComposeLRField]

87114

88115testADT1 :: Test

89116testADT1 = TestCase $ assertEqual "one record constructor" (Right example) (fromTuple (toTuple example))

@@ -121,7 +148,7 @@ testADT7 :: Test

121148testADT7 = TestCase $ do

122149 let example = Test7C (Test7AC 3)

123150 assertEqual "atom type" (Right example) (fromTuple (toTuple example))

124− let expectedAttrs = V.singleton (Attribute "" (ConstructedAtomType "Test7A" M.empty))

151+ let expectedAttrs = A.singleton (Attribute "" (ConstructedAtomType "Test7A" M.empty))

125152 assertEqual "adt atomtype" expectedAttrs (toAttributes (Proxy :: Proxy Test7T))

126153

127154testADT8 :: Test

@@ -195,8 +222,159 @@ testDeleteExpr = TestCase $ do

195222testReorderedTuple :: Test

196223testReorderedTuple = TestCase $ do

197224 let tupleRev :: RelationTuple -> RelationTuple

198− tupleRev (RelationTuple v1 v2) = RelationTuple (V.reverse v1) (V.reverse v2)

225+ tupleRev (RelationTuple v1 v2) = RelationTuple (revAttrs v1) (V.reverse v2)

226+ revAttrs attrs = A.attributesFromList (reverse (A.toList attrs))

199227 expected = Test2C {attrB = 3,

200228 attrC = 4}

201229 actual = fromTuple . tupleRev . toTuple $ expected

202230 assertEqual "reordered tuple" (Right expected) actual

231+

232+testCodec :: forall tag. ModifyOptions tag => String -> [AttributeName] -> Test

233+testCodec msg expected = TestCase $

234+ assertEqual msg (S.fromList expected) actual

235+ where

236+ actual = attributeNameSet $ toAttributes (Proxy :: Proxy (Codec tag Test10T))

237+

238+testAddPrefixField :: Test

239+testAddPrefixField = testCodec

240+ @(Field (AddPrefix "prefix_"))

241+ "codec field add prefix attributes"

242+ ["prefix_longAttrNameA10",

243+ "prefix_long_attr_name_b10",

244+ "prefix_longMixed_attr_NameC10"]

245+

246+testDropPrefixField :: Test

247+testDropPrefixField = testCodec

248+ @(Field (DropPrefix "long"))

249+ "codec field drop prefix"

250+ ["AttrNameA10",

251+ "_attr_name_b10",

252+ "Mixed_attr_NameC10"]

253+

254+testAddSuffixField :: Test

255+testAddSuffixField = testCodec

256+ @(Field (AddSuffix "_suffix"))

257+ "codec field add suffix"

258+ ["longAttrNameA10_suffix",

259+ "long_attr_name_b10_suffix",

260+ "longMixed_attr_NameC10_suffix"]

261+

262+testDropSuffixField :: Test

263+testDropSuffixField = testCodec

264+ @(Field (DropSuffix "10"))

265+ "codec field drop suffix"

266+ ["longAttrNameA",

267+ "long_attr_name_b",

268+ "longMixed_attr_NameC"]

269+

270+testUpperCaseField :: Test

271+testUpperCaseField = testCodec

272+ @(Field UpperCase)

273+ "codec field uppercase"

274+ ["LONGATTRNAMEA10",

275+ "LONG_ATTR_NAME_B10",

276+ "LONGMIXED_ATTR_NAMEC10"]

277+

278+testLowerCaseField :: Test

279+testLowerCaseField = testCodec

280+ @(Field LowerCase)

281+ "codec field lowercase"

282+ ["longattrnamea10",

283+ "long_attr_name_b10",

284+ "longmixed_attr_namec10"]

285+

286+testTitleCaseField :: Test

287+testTitleCaseField = testCodec

288+ @(Field TitleCase)

289+ "codec field title case"

290+ ["Long Attr Name A10",

291+ "Long Attr Name B10",

292+ "Long Mixed Attr Name C10"]

293+

294+testCamelCaseField :: Test

295+testCamelCaseField = testCodec

296+ @(Field CamelCase)

297+ "codec field camel case"

298+ ["longAttrNameA10",

299+ "longAttrNameB10",

300+ "longMixedAttrNameC10"]

301+

302+testPascalCaseField :: Test

303+testPascalCaseField = testCodec

304+ @(Field PascalCase)

305+ "codec field pascal case"

306+ ["LongAttrNameA10",

307+ "LongAttrNameB10",

308+ "LongMixedAttrNameC10"]

309+

310+testSnakeCaseField :: Test

311+testSnakeCaseField = testCodec

312+ @(Field SnakeCase)

313+ "codec field snake case"

314+ ["long_attr_name_a10",

315+ "long_attr_name_b10",

316+ "long_mixed_attr_name_c10"]

317+

318+testSpinalCaseField :: Test

319+testSpinalCaseField = testCodec

320+ @(Field SpinalCase)

321+ "codec field spinal case"

322+ ["long-attr-name-a10",

323+ "long-attr-name-b10",

324+ "long-mixed-attr-name-c10"]

325+

326+testTrainCaseField :: Test

327+testTrainCaseField = testCodec

328+ @(Field TrainCase)

329+ "codec field train case"

330+ ["Long-Attr-Name-A10",

331+ "Long-Attr-Name-B10",

332+ "Long-Mixed-Attr-Name-C10"]

333+

334+testAsIsCodec :: Test

335+testAsIsCodec = testCodec

336+ @AsIs

337+ "codec as is"

338+ ["longAttrNameA10",

339+ "long_attr_name_b10",

340+ "longMixed_attr_NameC10"]

341+

342+testAsIsField :: Test

343+testAsIsField = testCodec

344+ @(Field AsIs)

345+ "codec field as is"

346+ ["longAttrNameA10",

347+ "long_attr_name_b10",

348+ "longMixed_attr_NameC10"]

349+

350+testComposeRLCodec :: Test

351+testComposeRLCodec = testCodec

352+ @(Field UpperCase <<< Field (DropPrefix "long"))

353+ "codec (<<<)"

354+ ["ATTRNAMEA10",

355+ "_ATTR_NAME_B10",

356+ "MIXED_ATTR_NAMEC10"]

357+

358+testComposeRLField :: Test

359+testComposeRLField = testCodec

360+ @(Field (UpperCase <<< DropPrefix "long"))

361+ "codec field (<<<)"

362+ ["ATTRNAMEA10",

363+ "_ATTR_NAME_B10",

364+ "MIXED_ATTR_NAMEC10"]

365+

366+testComposeLRCodec :: Test

367+testComposeLRCodec = testCodec

368+ @(Field (DropPrefix "long") >>> Field UpperCase)

369+ "codec (>>>)"

370+ ["ATTRNAMEA10",

371+ "_ATTR_NAME_B10",

372+ "MIXED_ATTR_NAMEC10"]

373+

374+testComposeLRField :: Test

375+testComposeLRField = testCodec

376+ @(Field (DropPrefix "long" >>> UpperCase))

377+ "codec field (>>>)"

378+ ["ATTRNAMEA10",

379+ "_ATTR_NAME_B10",

380+ "MIXED_ATTR_NAMEC10"]

test/Server/Main.hs+24−23

@@ -5,7 +5,6 @@ test client/server interaction

55import Test.HUnit

66import ProjectM36.Client

77import qualified ProjectM36.Client as C

8−import ProjectM36.Server.EntryPoints

98import ProjectM36.Server

109import ProjectM36.Server.Config

1110import ProjectM36.Relation

@@ -14,16 +13,8 @@ import ProjectM36.IsomorphicSchema

1413import ProjectM36.Base

1514

1615import System.Exit

17−

16+import Network.Socket (SockAddr(..))

1817import Control.Concurrent

19−import Network.Transport (EndPointAddress)

20−

21−#if MIN_VERSION_network_transport_tcp(0,6,0)

22−import Network.Transport.TCP.Internal (encodeEndPointAddress, decodeEndPointAddress)

23−#else

24−import Network.Transport.TCP (encodeEndPointAddress, decodeEndPointAddress)

25−#endif

26−

2718import Data.Either (isRight)

2819import Control.Exception

2920import System.IO.Temp

@@ -32,6 +23,8 @@ import System.FilePath

3223import System.Directory

3324#endif

3425

26+type Timeout = Int

27+

3528testList :: SessionId -> Connection -> MVar () -> Test

3629testList sessionId conn notificationTestMVar = TestList $ serverTests ++ sessionTests

3730 where

@@ -49,7 +42,7 @@ testList sessionId conn notificationTestMVar = TestList $ serverTests ++ session

4942 testRelationVariableSummary,

5043 testNotification notificationTestMVar

5144 ]

52− serverTests = [testRequestTimeout, testFileDescriptorCount]

45+ serverTests = [testRequestTimeout, testFileDescriptorCount, testClientConnectFail]

5346

5447main :: IO ()

5548main = do

@@ -69,11 +62,9 @@ main = do

6962testDatabaseName :: DatabaseName

7063testDatabaseName = "test"

7164

72−testConnection :: EndPointAddress -> MVar () -> IO (Either ConnectionError (SessionId, Connection))

73−testConnection serverAddress mvar = do

74− let Just (host, service, _) = decodeEndPointAddress serverAddress

75− serverAddress' = encodeEndPointAddress host service 1

76− let connInfo = RemoteProcessConnectionInfo testDatabaseName (NodeId serverAddress') (testNotificationCallback mvar)

65+testConnection :: Port -> MVar () -> IO (Either ConnectionError (SessionId, Connection))

66+testConnection serverPort mvar = do

67+ let connInfo = RemoteConnectionInfo testDatabaseName "127.0.0.1" (show serverPort) (testNotificationCallback mvar)

7768 --putStrLn ("testConnection: " ++ show serverAddress)

7869 eConn <- connectProjectM36 connInfo

7970 case eConn of

@@ -85,7 +76,7 @@ testConnection serverAddress mvar = do

8576 Right sessionId -> pure $ Right (sessionId, conn)

8677

8778-- | A version of 'launchServer' which returns the port on which the server is listening on a secondary thread

88−launchTestServer :: Timeout -> IO (EndPointAddress, ThreadId)

79+launchTestServer :: Timeout -> IO (Port, ThreadId)

8980launchTestServer ti = do

9081 addressMVar <- newEmptyMVar

9182 tid <- forkIO $

@@ -94,13 +85,14 @@ launchTestServer ti = do

9485 persistenceStrategy = CrashSafePersistence (tempdir </> "db"),

9586 perRequestTimeout = ti,

9687 testMode = True,

97− bindPort = 0

88+ bindPort = 0,

89+ checkFS = False --not stricly needed for these tests

9890 }

9991

10092 launchServer config (Just addressMVar) >> pure ()

101− endPointAddress <- takeMVar addressMVar

93+ (SockAddrInet port _) <- takeMVar addressMVar

10294 --liftIO $ putStrLn ("launched server on " ++ show endPointAddress)

103− pure (endPointAddress, tid)

95+ pure (fromIntegral port, tid)

10496

10597testRelationalExpr :: SessionId -> Connection -> Test

10698testRelationalExpr sessionId conn = TestCase $ do

@@ -146,10 +138,11 @@ testPlanForDatabaseContextExpr sessionId conn = TestCase $ do

146138 let attrExprs = [AttributeAndTypeNameExpr "x" (PrimitiveTypeConstructor "Int" IntAtomType) ()]

147139 testrv = "testrv"

148140 dbExpr = Define testrv attrExprs

141+ expected = Define testrv [AttributeAndTypeNameExpr "x" (PrimitiveTypeConstructor "Int" IntAtomType) UncommittedContextMarker]

149142 planResult <- planForDatabaseContextExpr sessionId conn dbExpr

150143 case planResult of

151144 Left err -> assertFailure (show err)

152− Right plan -> assertEqual "planForDatabaseContextExpr failure" dbExpr plan

145+ Right plan -> assertEqual "planForDatabaseContextExpr failure" expected plan

153146

154147testTransactionGraphAsRelation :: SessionId -> Connection -> Test

155148testTransactionGraphAsRelation sessionId conn = TestCase $ do

@@ -215,7 +208,7 @@ testRequestTimeout = TestCase $ do

215208 Left err -> putStrLn ("failed to connect: " ++ show err) >> exitFailure

216209 Right (session, testConn) -> do

217210 res <- catchJust (\exc -> if exc == RequestTimeoutException then Just exc else Nothing) (callTestTimeout_ session testConn) (const (pure False))

218− assertBool "exception was not thrown" (not res)

211+ assertBool "timeout exception was not thrown" (not res)

219212 killThread serverTid

220213

221214testFileDescriptorCount :: Test

@@ -244,4 +237,12 @@ fdCount = do

244237#else

245238--pass on non-linux platforms

246239testFileDescriptorCount = TestCase (pure ())

247−#endif

240+#endif

241+

242+testClientConnectFail :: Test

243+testClientConnectFail = TestCase $ do

244+ let connInfo = RemoteConnectionInfo "nonexistentdb" "127.0.0.1" "7777" emptyNotificationCallback

245+ eConn <- connectProjectM36 connInfo

246+ case eConn of

247+ Left (IOExceptionError _) -> pure ()

248+ _ -> assertFailure "connection failure failed"

test/Server/WebSocket.hs+8−12

@@ -18,12 +18,6 @@ import Data.Aeson

1818import qualified Data.Map as M

1919import qualified Data.ByteString.Lazy as BS

2020import ProjectM36.Relation

21−#if MIN_VERSION_network_transport_tcp(0,6,0)

22−import Network.Transport.TCP.Internal (decodeEndPointAddress)

23−#else

24−import Network.Transport.TCP (decodeEndPointAddress)

25−#endif

26−

2721

2822--start the websocket server

2923-- run some tutoriald against it

@@ -32,16 +26,17 @@ launchTestServer :: IO (PortNumber, DatabaseName)

3226launchTestServer = do

3327 addressMVar <- newEmptyMVar

3428 let config = defaultServerConfig { databaseName = testDatabaseName,

35− bindPort = 0 }

29+ bindPort = 0,

30+ checkFS = False}

3631 testDatabaseName = "test"

3732 -- start normal server

3833 _ <- forkIO (launchServer config (Just addressMVar) >> pure ())

39− serverAddress <- takeMVar addressMVar

34+ (SockAddrInet dbPort _) <- takeMVar addressMVar

4035 let wsServerHost = "127.0.0.1"

4136 wsServerPort = 8889

42− Just (dbHost, dbPort, _) = decodeEndPointAddress serverAddress

37+ dbHost = "127.0.0.1"

4338 -- start websocket server proxy -- runServer doesn't support returning an arbitrary socket

44− _ <- forkIO (WS.runServer wsServerHost wsServerPort (websocketProxyServer (read dbPort) dbHost))

39+ _ <- forkIO (WS.runServer wsServerHost wsServerPort (websocketProxyServer (fromIntegral dbPort) dbHost))

4540 --wait for socket to be listening

4641 waitForListenSocket 5 (fromIntegral wsServerPort)

4742 pure (fromIntegral wsServerPort, testDatabaseName)

@@ -56,13 +51,14 @@ waitForListenSocket secondsToTry port =

5651 if secondsToTry <= 0 then

5752 throw WaitForSocketListenException

5853 else do

59− hostaddr <- inet_addr "127.0.0.1"

54+ --hostaddr <- inet_addr "127.0.0.1"

55+ hostaddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just (show port))

6056 sock <- socket AF_INET Stream defaultProtocol

6157 let handler :: IOException -> IO ()

6258 handler _ = do

6359 threadDelay 1000000

6460 waitForListenSocket (secondsToTry - 1) port

65− catch (connect sock (SockAddrInet port hostaddr)) handler

61+ catch (connect sock (addrAddress hostaddr)) handler

6662

6763main :: IO ()

6864main = do

test/TransactionGraph/Merge.hs+70−39

@@ -4,15 +4,28 @@ import ProjectM36.Base

44import ProjectM36.Attribute

55import ProjectM36.Relation

66import ProjectM36.Transaction

7+import ProjectM36.TransactionInfo as TI

78import ProjectM36.TransactionGraph

89import ProjectM36.Error

910import ProjectM36.Key

1011import qualified ProjectM36.DisconnectedTransaction as Discon

1112import qualified ProjectM36.DatabaseContext as DBC

1213import ProjectM36.RelationalExpression

14+import ProjectM36.StaticOptimizer

1315

1416import qualified Data.ByteString.Lazy as BS

1517import System.Exit

18+

19+

20+

21+

22+

23+

24+

25+

26+

27+

28+

1629import Data.Word

1730import qualified Data.UUID as U

1831import qualified Data.Set as S

@@ -21,8 +34,6 @@ import Data.Maybe

2134import Data.Time.Clock

2235import Data.Time.Calendar

2336

24−import Control.Monad.State

25−

2637{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

2738

2839testTime :: UTCTime

@@ -62,8 +73,8 @@ basicTransactionGraph = do

6273 uuidB = fakeUUID 11

6374 uuidRoot = fakeUUID 1

6475 rootContext = concreteDatabaseContext rootTrans

65− (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TransactionInfo S.empty testTime) rootContext) bsGraph

66− (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TransactionInfo S.empty testTime) rootContext) bsGraph'

76+ (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TI.singleParent uuidRoot testTime) rootContext) bsGraph

77+ (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TI.singleParent uuidRoot testTime) rootContext) bsGraph'

6778 pure bsGraph''

6879

6980addTransaction :: HeadName -> Transaction -> TransactionGraph -> IO (Transaction, TransactionGraph)

@@ -107,7 +118,7 @@ testSubGraphToFirstAncestorSnipBranch = TestCase $ do

107118 baseGraph <- basicTransactionGraph

108119 transA <- assertMaybe (transactionForHead "branchA" baseGraph) "failed to get branchA"

109120 transB <- assertMaybe (transactionForHead "branchB" baseGraph) "failed to get branchB"

110− (_, graph) <- addTransaction "branchC" (createTrans (fakeUUID 12) (TransactionInfo (fakeUUID 1) S.empty testTime) (concreteDatabaseContext transA)) baseGraph

121+ (_, graph) <- addTransaction "branchC" (createTrans (fakeUUID 12) (TI.singleParent (fakeUUID 1) testTime) (concreteDatabaseContext transA)) baseGraph

111122 subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph baseGraph) transA transB S.empty

112123 assertGraph subgraph

113124 let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)

@@ -121,16 +132,18 @@ testSubGraphToFirstAncestorMoreTransactions = TestCase $ do

121132

122133-- add another relvar to branchB

123134 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"

124− (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of

125− (Left err, _) -> assertFailure (show err) >> undefined

126− (Right (), context) -> pure context

127− (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph

135+ let env = mkDatabaseContextEvalEnv (transactionId branchBTrans) graph

136+ branchBContext = concreteDatabaseContext branchBTrans

137+ updatedBranchBContext <- case runDatabaseContextEvalMonad branchBContext env (optimizeAndEvalDatabaseContextExpr True (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) of

138+ Left err -> assertFailure (show err) >> undefined

139+ Right st -> pure $ dbc_context st

140+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchBTrans) testTime) updatedBranchBContext) graph

128141 branchBTrans' <- assertMaybe (transactionForHead "branchB" graph') "failed to get branchB head"

129142 assertEqual "branchB id 3" (fakeUUID 3) (transactionId branchBTrans')

130143

131144 -- add another transaction to branchA

132145 branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head"

133− (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) (concreteDatabaseContext branchATrans)) graph'

146+ (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TI.singleParent (transactionId branchATrans) testTime) (concreteDatabaseContext branchATrans)) graph'

134147 branchATrans' <- assertMaybe (transactionForHead "branchA" graph'') "failed to get branchA head"

135148 assertEqual "branchA id 4" (fakeUUID 4) (transactionId branchATrans')

136149

@@ -148,12 +161,15 @@ testSelectedBranchMerge = TestCase $ do

148161

149162 -- add another relvar to branchB

150163 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"

151− (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of

152− (Left err, _) -> assertFailure (show err) >> undefined

153− (Right (), context) -> pure context

154− (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph

164+ let env = mkDatabaseContextEvalEnv (transactionId branchBTrans) graph

165+ branchBContext = concreteDatabaseContext branchBTrans

166+ updatedBranchBContext <- case runDatabaseContextEvalMonad branchBContext env (optimizeAndEvalDatabaseContextExpr True (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) of

167+ Left err -> assertFailure (show err) >> undefined

168+ Right st -> pure (dbc_context st)

169+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchBTrans) testTime) updatedBranchBContext) graph

155170 --create the merge transaction in the graph

156− let eGraph' = mergeTransactions testTime (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB") graph'

171+ let eGraph' = runGraphRefRelationalExprM gfEnv $ mergeTransactions testTime (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB")

172+ gfEnv = freshGraphRefRelationalExprEnv Nothing graph'

157173

158174 (_, graph'') <- assertEither eGraph'

159175

@@ -175,18 +191,22 @@ testUnionPreferMergeStrategy = TestCase $ do

175191 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "branchBTrans"

176192 branchBRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) []

177193 let branchAContext = (concreteDatabaseContext branchATrans) {relationVariables = M.insert conflictRelVarName branchARelVar (relationVariables (concreteDatabaseContext branchATrans))}

178− branchARelVar = relationTrue

179− branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert conflictRelVarName branchBRelVar (relationVariables (concreteDatabaseContext branchBTrans))}

180− conflictRelVarName = "conflictRelVar"

194+ branchARelVar = ExistingRelation relationTrue

195+ branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert conflictRelVarName (ExistingRelation branchBRelVar) (relationVariables (concreteDatabaseContext branchBTrans))}

196+ conflictRelVarName = "conflictRelVar"

181197

182− (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchATrans) S.empty testTime) branchAContext) graph

183− (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchBTrans) S.empty testTime) branchBContext) graph'

198+ (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchATrans) testTime) branchAContext) graph

199+ (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TI.singleParent (transactionId branchBTrans) testTime) branchBContext) graph'

184200 -- validate that the conflict is hidden because we preferred a branch

185− let merged = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) (UnionPreferMergeStrategy "branchB") ("branchA", "branchB") graph''

201+ let merged = runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) (UnionPreferMergeStrategy "branchB") ("branchA", "branchB")

202+ env = freshGraphRefRelationalExprEnv Nothing graph''

186203 case merged of

187204 Left err -> assertFailure ("expected merge success: " ++ show err)

188− Right (discon, _) ->

189− assertEqual "branchB relvar preferred in conflict" (Just branchBRelVar) (M.lookup conflictRelVarName (relationVariables (Discon.concreteDatabaseContext discon)))

205+ Right (discon, _) -> do

206+ let Just rvExpr = M.lookup conflictRelVarName (relationVariables (Discon.concreteDatabaseContext discon))

207+ reEnv = freshGraphRefRelationalExprEnv (Just (Discon.concreteDatabaseContext discon)) graph

208+ let eRvRel = runGraphRefRelationalExprM reEnv (evalGraphRefRelationalExpr rvExpr)

209+ assertEqual "branchB relvar preferred in conflict" (Right branchBRelVar) eRvRel

190210

191211-- try various individual component conflicts and check for merge failure

192212testUnionMergeStrategy :: Test

@@ -201,31 +221,41 @@ testUnionMergeStrategy = TestCase $ do

201221

202222 let updatedBranchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert branchBOnlyRelVarName branchBOnlyRelVar (relationVariables (concreteDatabaseContext branchBTrans)) }

203223 updatedBranchAContext = (concreteDatabaseContext branchATrans) {inclusionDependencies = M.insert branchAOnlyIncDepName branchAOnlyIncDep (inclusionDependencies (concreteDatabaseContext branchATrans)) }

204− branchBOnlyRelVar = relationTrue

224+ branchBOnlyRelVar = ExistingRelation relationTrue

205225 branchAOnlyIncDepName = "branchAOnlyIncDep"

206226 branchBOnlyRelVarName = "branchBOnlyRelVar"

207227 branchAOnlyIncDep = InclusionDependency (ExistingRelation relationTrue) (ExistingRelation relationTrue)

208− (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph

209− (discon, _) <- assertEither $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 10) UnionMergeStrategy ("branchA", "branchB") graph'

210− assertEqual "branchBOnlyRelVar should appear in the merge" (M.lookup branchBOnlyRelVarName (relationVariables (Discon.concreteDatabaseContext discon))) (Just relationTrue)

211− (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) updatedBranchAContext) graph'

212− let eMergeGraph = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph''

228+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchBTrans) testTime) updatedBranchBContext) graph

229+ let env = freshGraphRefRelationalExprEnv Nothing graph'

230+ (discon, _) <- assertEither $ runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 10) UnionMergeStrategy ("branchA", "branchB")

231+ let Just rvExpr = M.lookup branchBOnlyRelVarName (relationVariables (Discon.concreteDatabaseContext discon))

232+ Right rvRel = runGraphRefRelationalExprM reEnv (evalGraphRefRelationalExpr rvExpr)

233+ reEnv = freshGraphRefRelationalExprEnv (Just (Discon.concreteDatabaseContext discon)) graph

234+

235+ assertEqual "branchBOnlyRelVar should appear in the merge" relationTrue rvRel

236+ (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TI.singleParent (transactionId branchATrans) testTime) updatedBranchAContext) graph'

237+ let eMergeGraph = runGraphRefRelationalExprM gfEnv $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB")

238+ gfEnv = freshGraphRefRelationalExprEnv Nothing graph''

213239 case eMergeGraph of

214240 Left err -> assertFailure ("expected merge success: " ++ show err)

215241 Right (_, mergeGraph) -> do

216242 -- check that the new merge transaction has the correct parents

217243 mergeTrans <- assertEither $ transactionForId (fakeUUID 5) mergeGraph

218244 let mergeContext = concreteDatabaseContext mergeTrans

219− assertEqual "merge transaction parents" (transactionParentIds mergeTrans) (S.fromList [fakeUUID 3, fakeUUID 4])

245+ assertEqual "merge transaction parents" (parentIds mergeTrans) (S.fromList [fakeUUID 3, fakeUUID 4])

220246 -- check that the new merge tranasction has elements from both A and B branches

221− assertEqual "merge transaction relvars" (Just relationTrue) (M.lookup branchBOnlyRelVarName (relationVariables mergeContext))

247+ let Just rvExpr' = M.lookup branchBOnlyRelVarName (relationVariables mergeContext)

248+ Right rvRel' = runGraphRefRelationalExprM reEnv' (evalGraphRefRelationalExpr rvExpr')

249+ reEnv' = freshGraphRefRelationalExprEnv (Just mergeContext) graph

250+ assertEqual "merge transaction relvars" relationTrue rvRel'

222251 assertEqual "merge transaction incdeps" (Just branchAOnlyIncDep) (M.lookup branchAOnlyIncDepName (inclusionDependencies mergeContext))

223252 -- test an expected conflict- add branchBOnlyRelVar with same name but different attributes

224253 conflictRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) []

225− let conflictContextA = updatedBranchAContext {relationVariables = M.insert branchBOnlyRelVarName conflictRelVar (relationVariables updatedBranchAContext) }

254+ let conflictContextA = updatedBranchAContext {relationVariables = M.insert branchBOnlyRelVarName (ExistingRelation conflictRelVar) (relationVariables updatedBranchAContext) }

226255 conflictBranchATrans <- assertMaybe (transactionForHead "branchA" graph'') "retrieving head transaction for expected conflict"

227− (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TransactionInfo (transactionId conflictBranchATrans) S.empty testTime) conflictContextA) graph''

228− let failingMerge = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph'''

256+ (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TI.singleParent (transactionId conflictBranchATrans) testTime) conflictContextA) graph''

257+ let failingMerge = runGraphRefRelationalExprM gfEnv' $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB")

258+ gfEnv' = freshGraphRefRelationalExprEnv Nothing graph'''

229259 case failingMerge of

230260 Right _ -> assertFailure "expected merge failure"

231261 Left err -> assertEqual "merge failure" err (MergeTransactionError StrategyViolatesRelationVariableMergeError)

@@ -244,20 +274,21 @@ testUnionMergeIncDepViolation = TestCase $ do

244274 rvName = "x"

245275 Right branchArv = eRel 2

246276 Right branchBrv = eRel 3

247− branchAContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName branchArv}

248− branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName branchBrv,

277+ branchAContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName (ExistingRelation branchArv)}

278+ branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName (ExistingRelation branchBrv),

249279 inclusionDependencies = M.singleton incDepName incDep}

250280 incDepName = "x_key"

251281 incDep = inclusionDependencyForKey (AttributeNames (S.singleton "x")) (RelationVariable "x" ())

252282

253283

254284 --add the rv in new commits to both branches

255− (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) branchBContext) graph

285+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchBTrans) testTime) branchBContext) graph

256286

257− (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) branchAContext) graph'

287+ (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TI.singleParent (transactionId branchATrans) testTime) branchAContext) graph'

258288

259289 --check that the union merge fails due to a violated constraint

260− let eMerge = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph''

290+ let eMerge = runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB")

291+ env = freshGraphRefRelationalExprEnv Nothing graph''

261292 case eMerge of

262293 Left (InclusionDependencyCheckError incDepName') -> assertEqual "incdep violation name" incDepName incDepName'

263294 Left err -> assertFailure ("other error: " ++ show err)

test/TransactionGraph/Persist.hs+79−15

@@ -1,14 +1,14 @@

1+{-# LANGUAGE CPP #-}

12import Test.HUnit

23import ProjectM36.Base

34import ProjectM36.Persist (DiskSync(NoDiskSync))

45import ProjectM36.TransactionGraph.Persist

5−import ProjectM36.TransactionGraph

6+import ProjectM36.TransactionGraph as TG

67import ProjectM36.Transaction

78import ProjectM36.DateExamples

8−import ProjectM36.Client

9−import ProjectM36.Relation

109import System.IO.Temp

1110import System.Exit

11+import System.Directory

1212import Data.Either

1313import Data.UUID.V4 (nextRandom)

1414import System.FilePath

@@ -17,6 +17,9 @@ import qualified Data.Map as M

1717import qualified Data.Set as S

1818import Data.Time.Clock

1919import Data.Time.Calendar

20+import ProjectM36.Client as C

21+import ProjectM36.Relation

22+import ProjectM36.Transaction.Persist

2023

2124main :: IO ()

2225main = do

@@ -26,11 +29,12 @@ main = do

2629testList :: Test

2730testList = TestList [testBootstrapDB,

2831 testDBSimplePersistence,

29− testFunctionPersistence]

32+ testFunctionPersistence,

33+ testMerkleHashValidation]

3034

3135

32−stamp :: UTCTime

33−stamp = UTCTime (fromGregorian 1980 01 01) (secondsToDiffTime 1000)

36+stamp' :: UTCTime

37+stamp' = UTCTime (fromGregorian 1980 01 01) (secondsToDiffTime 1000)

3438

3539{- bootstrap a database, ensure that it can be read -}

3640testBootstrapDB :: Test

@@ -38,7 +42,7 @@ testBootstrapDB = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> d

3842 let dbdir = tempdir </> "dbdir"

3943 freshId <- nextRandom

4044

41− _ <- bootstrapDatabaseDir NoDiskSync dbdir (bootstrapTransactionGraph stamp freshId dateExamples)

45+ _ <- bootstrapDatabaseDir NoDiskSync dbdir (bootstrapTransactionGraph stamp' freshId dateExamples)

4246 loadedGraph <- transactionGraphLoad dbdir emptyTransactionGraph Nothing

4347 assertBool "transactionGraphLoad" $ isRight loadedGraph

4448

@@ -48,17 +52,17 @@ testDBSimplePersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \temp

4852 let dbdir = tempdir </> "dbdir"

4953 freshId <- nextRandom

5054

51− let graph = bootstrapTransactionGraph stamp freshId dateExamples

55+ let graph = bootstrapTransactionGraph stamp' freshId dateExamples

5256 _ <- bootstrapDatabaseDir NoDiskSync dbdir graph

5357 case transactionForHead "master" graph of

5458 Nothing -> assertFailure "Failed to retrieve head transaction for master branch."

5559 Just headTrans ->

56− case interpretDatabaseContextExpr (concreteDatabaseContext headTrans) "x:=s" of

60+ case interpretDatabaseContextExpr (concreteDatabaseContext headTrans) (transactionId headTrans) graph "x:=s" of

5761 Left err -> assertFailure (show err)

5862 Right context' -> do

5963 freshId' <- nextRandom

60− let newdiscon = DisconnectedTransaction (transactionId headTrans) (Schemas context' M.empty) True

61− addTrans = addDisconnectedTransaction stamp freshId' "master" newdiscon graph

64+ let newdiscon = DisconnectedTransaction (transactionId headTrans) (Schemas context' M.empty) False

65+ addTrans = addDisconnectedTransaction stamp' freshId' "master" newdiscon graph

6266 --add a transaction to the graph

6367 case addTrans of

6468 Left err -> assertFailure (show err)

@@ -71,11 +75,69 @@ testDBSimplePersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \temp

7175 case graphErr of

7276 Left err -> assertFailure (show err)

7377 Right graph'' -> assertBool "graph equality" (mapEq graph'' == mapEq graph')

74−

78+

79+testMerkleHashValidation :: Test

80+testMerkleHashValidation = TestCase $

81+ -- add a commit and validate the hashes successfully

82+ withSystemTempDirectory "m36testdb" $ \tempdir -> do

83+ let dbdir = tempdir </> "dbdir"

84+ connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []

85+ conn <- assertIOEither $ connectProjectM36 connInfo

86+ sess <- assertIOEither $ createSessionAtHead conn "master"

87+ Right _ <- executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue))

88+ Right _ <- commit sess conn

89+ val <- C.validateMerkleHashes sess conn

90+ assertEqual "merkle success" (Right ()) val

91+

92+ --read graph from disk

93+ conn' <- assertIOEither $ connectProjectM36 connInfo

94+ sess' <- assertIOEither $ createSessionAtHead conn' "master"

95+

96+ val' <- C.validateMerkleHashes sess' conn'

97+ assertEqual "merkle read again success" (Right ()) val'

98+

99+ --alter the on-disk representation and check that the hash validation fails

100+ eGraph <- transactionGraphLoad dbdir emptyTransactionGraph Nothing

101+ case eGraph of

102+ Left err -> assertFailure $ "failed to load graph" ++ show err

103+ Right graph -> do

104+ let trans = transactionHeadsForGraph graph M.! "master"

105+ updatedTrans = Transaction (transactionId trans) (transactionInfo trans) updatedSchemas

106+ transactionDir' = dbdir </> show (transactionId trans)

107+ updatedSchemas =

108+ case schemas trans of

109+ Schemas ctx sschemas ->

110+ let updatedContext = ctx {

111+ relationVariables = M.insert "malicious" (ExistingRelation relationFalse) (relationVariables ctx)

112+ } in

113+ Schemas updatedContext sschemas

114+ maliciousGraph = TransactionGraph malHeads malTransSet

115+ malHeads = M.insert "master" updatedTrans (transactionHeadsForGraph graph)

116+ malTransSet = S.insert updatedTrans (transactionsForGraph graph)

117+ malMerkleHash = calculateMerkleHash updatedTrans maliciousGraph

118+ regMerkleHash = merkleHash (transactionInfo trans)

119+ --validate and fail

120+ let val'' = TG.validateMerkleHashes maliciousGraph

121+ assertEqual "loaded graph merkle hashes" (Left [MerkleValidationError (transactionId trans) regMerkleHash malMerkleHash]) val''

122+ --delete existing transaction directory

123+ removeDirectoryRecursive transactionDir'

124+ writeTransaction NoDiskSync dbdir updatedTrans

125+

126+ --read graph from disk

127+ eConnFail <- connectProjectM36 connInfo

128+ case eConnFail of

129+ Left err ->

130+ assertEqual "open connection merkle validation" (DatabaseValidationError [MerkleValidationError (transactionId trans) regMerkleHash malMerkleHash]) err

131+ Right _ -> assertFailure "open connection validation"

132+

133+

75134

76135--only Haskell-scripted dbc and atom functions can be serialized

77136testFunctionPersistence :: Test

78−testFunctionPersistence = TestCase $

137+#if !defined(PM36_HASKELL_SCRIPTING)

138+testFunctionPersistence = TestCase $ pure ()

139+#else

140+testFunctionPersistence = TestCase $

79141 withSystemTempDirectory "m36testdb" $ \tempdir -> do

80142 let dbdir = tempdir </> "dbdir"

81143 connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []

@@ -93,10 +155,12 @@ testFunctionPersistence = TestCase $

93155 conn2 <- assertIOEither $ connectProjectM36 connInfo

94156 sess2 <- assertIOEither $ createSessionAtHead conn2 "master"

95157

96− res <- executeRelationalExpr sess2 conn2 (MakeRelationFromExprs Nothing [TupleExpr (M.singleton "a" (FunctionAtomExpr "testdisk" [NakedAtomExpr (IntAtom 3)] ()))])

158+ res <- executeRelationalExpr sess2 conn2 (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (M.singleton "a" (FunctionAtomExpr "testdisk" [NakedAtomExpr (IntAtom 3)] ()))]))

97159 let expectedRel = mkRelationFromList (attributesFromList [Attribute "a" IntAtomType]) [[IntAtom 3]]

98160 assertEqual "testdisk dbc function run" expectedRel res

99−

161+

162+#endif

163+

100164assertIOEither :: (Show a) => IO (Either a b) -> IO b

101165assertIOEither x = do

102166 ret <- x

test/TutorialD/Interpreter/AtomFunctionScript.hs+25−17

@@ -1,25 +1,32 @@

1−import TutorialD.Interpreter.TestBase

1+{-# LANGUAGE CPP #-}

22import System.Exit

33import Test.HUnit

4+#ifdef PM36_HASKELL_SCRIPTING

5+import TutorialD.Interpreter.TestBase

46import ProjectM36.Client

57import ProjectM36.Relation

68import ProjectM36.DataTypes.Maybe

79import qualified Data.Vector as V

810import qualified Data.Map as M

11+#endif

912

1013{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

1114main :: IO ()

1215main = do

13− tcounts <- runTestTT (TestList [testBasicAtomFunction,

14− testExceptionAtomFunction,

15− testErrorAtomFunction,

16− testNoArgumentAtomFunction,

17− testArgumentTypeMismatch,

18− testPolymorphicReturnType,

19− testScriptedTypeVariable

20− ])

16+ tcounts <- runTestTT (TestList [

17+#ifdef PM36_HASKELL_SCRIPTING

18+ testBasicAtomFunction,

19+ testExceptionAtomFunction,

20+ testErrorAtomFunction,

21+ testNoArgumentAtomFunction,

22+ testArgumentTypeMismatch,

23+ testPolymorphicReturnType,

24+ testScriptedTypeVariable

25+#endif

26+ ])

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

2228

29+#ifdef PM36_HASKELL_SCRIPTING

2330--add an atom function and run it

2431testBasicAtomFunction :: Test

2532testBasicAtomFunction = TestCase $ do

@@ -29,7 +36,7 @@ testBasicAtomFunction = TestCase $ do

2936 funcAtomExpr = FunctionAtomExpr "mkTest" [NakedAtomExpr (IntegerAtom 3)] ()

3037 tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]

3138 expectedResult = mkRelationFromList (V.fromList attrs) [[IntegerAtom 3]]

32− result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)

39+ result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) (TupleExprs () tupleExprs))

3340

3441 assertEqual "simple atom function equality" expectedResult result

3542

@@ -40,7 +47,7 @@ testExceptionAtomFunction = TestCase $ do

4047 executeTutorialD sess conn "addatomfunction \"mkTest\" Integer -> Either AtomFunctionError Integer \"\"\"(\\(IntegerAtom x:xs) -> (error (show 1))) :: [Atom] -> Either AtomFunctionError Atom\"\"\""

4148 let attrs = [Attribute "x" IntegerAtomType]

4249 funcAtomExpr = FunctionAtomExpr "mkTest" [NakedAtomExpr (IntegerAtom 3)] ()

43− tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]

50+ tupleExprs = TupleExprs () [TupleExpr (M.singleton "x" funcAtomExpr)]

4451 result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)

4552 assertBool "catch error exception from script" (case result of

4653 Left (UnhandledExceptionError _) -> True

@@ -57,7 +64,7 @@ testNoArgumentAtomFunction = TestCase $ do

5764 executeTutorialD sess conn "addatomfunction \"mkTest\" Either AtomFunctionError Integer \"\"\"(\\x -> pure (IntegerAtom 5)) :: [Atom] -> Either AtomFunctionError Atom\"\"\""

5865 let attrs = [Attribute "x" IntegerAtomType]

5966 funcAtomExpr = FunctionAtomExpr "mkTest" [] ()

60− tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]

67+ tupleExprs = TupleExprs () [TupleExpr (M.singleton "x" funcAtomExpr)]

6168 expectedResult = mkRelationFromList (V.fromList attrs) [[IntegerAtom 5]]

6269 result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)

6370 assertEqual "no argument scripted function" expectedResult result

@@ -66,7 +73,7 @@ testArgumentTypeMismatch :: Test

6673testArgumentTypeMismatch = TestCase $ do

6774 (sess, conn) <- dateExamplesConnection emptyNotificationCallback

6875 executeTutorialD sess conn "addatomfunction \"mkTest\" Integer -> Either AtomFunctionError Integer \"\"\"(\\(IntegerAtom x:_) -> pure $ TextAtom \"wrong type\") :: [Atom] -> Either AtomFunctionError Atom\"\"\""

69− let tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]

76+ let tupleExprs = TupleExprs () [TupleExpr (M.singleton "x" funcAtomExpr)]

7077 funcAtomExpr = FunctionAtomExpr "mkTest" [NakedAtomExpr (IntegerAtom 3)] ()

7178 attrs = [Attribute "x" IntegerAtomType]

7279 expectedResult = Left (AtomTypeMismatchError IntegerAtomType TextAtomType)

@@ -80,7 +87,7 @@ testPolymorphicReturnType = TestCase $ do

8087 let funcAtomExpr = FunctionAtomExpr "fromMaybe" [NakedAtomExpr (IntegerAtom 5),

8188 NakedAtomExpr maybeAtom] ()

8289 maybeAtom = ConstructedAtom "Just" (maybeAtomType IntegerAtomType) [IntegerAtom 3]

83− relExpr = MakeRelationFromExprs Nothing [TupleExpr (M.singleton "x" funcAtomExpr)]

90+ relExpr = MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (M.singleton "x" funcAtomExpr)])

8491 mRelType <- typeForRelationalExpr sess conn relExpr

8592 case mRelType of

8693 Left err -> assertFailure (show err)

@@ -94,7 +101,7 @@ testPolymorphicReturnType = TestCase $ do

94101 let failFuncAtomExpr = FunctionAtomExpr "fromMaybe" [NakedAtomExpr (IntegerAtom 5),

95102 NakedAtomExpr mismatchAtom] ()

96103 mismatchAtom = ConstructedAtom "Just" (maybeAtomType TextAtomType) [TextAtom "fail"]

97− failRelExpr = MakeRelationFromExprs Nothing [TupleExpr (M.singleton "x" failFuncAtomExpr)]

104+ failRelExpr = MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (M.singleton "x" failFuncAtomExpr)])

98105 mFailRes <- executeRelationalExpr sess conn failRelExpr

99106 let expectedErr = Left (AtomFunctionTypeVariableMismatch "a" IntegerAtomType TextAtomType)

100107 assertEqual "expected type variable mismatch" expectedErr mFailRes

@@ -106,9 +113,10 @@ testScriptedTypeVariable = TestCase $ do

106113 executeTutorialD sess conn "addatomfunction \"idTest\" a -> Either AtomFunctionError a \"(\\\\(x:_) -> pure x) :: [Atom] -> Either AtomFunctionError Atom\""

107114 let attrs = [Attribute "x" IntegerAtomType]

108115 funcAtomExpr = FunctionAtomExpr "idTest" [NakedAtomExpr (IntegerAtom 3)] ()

109− tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]

116+ tupleExprs = TupleExprs () [TupleExpr (M.singleton "x" funcAtomExpr)]

110117 expectedResult = mkRelationFromList (V.fromList attrs) [[IntegerAtom 3]]

111118 result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)

112119

113120 assertEqual "id function equality" expectedResult result

114−

121+

122+#endif

test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs+13−6

@@ -1,19 +1,26 @@

1−import TutorialD.Interpreter.TestBase

1+{-# LANGUAGE CPP #-}

22import System.Exit

33import Test.HUnit

4+#ifdef PM36_HASKELL_SCRIPTING

5+import TutorialD.Interpreter.TestBase

46import ProjectM36.Client

57import ProjectM36.Relation

68import qualified Data.Text as T

9+#endif

710

811main :: IO ()

912main = do

10− tcounts <- runTestTT (TestList [testBasicDBCFunction,

11− testErrorDBCFunction,

12− testExceptionDBCFunction,

13− testDBCFunctionWithAtomArguments

13+ tcounts <- runTestTT (TestList [

14+#ifdef PM36_HASKELL_SCRIPTING

15+ testBasicDBCFunction,

16+ testErrorDBCFunction,

17+ testExceptionDBCFunction,

18+ testDBCFunctionWithAtomArguments

19+#endif

1420 ])

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

1622

23+#ifdef PM36_HASKELL_SCRIPTING

1724testBasicDBCFunction :: Test

1825testBasicDBCFunction = TestCase $ do

1926 (sess, conn) <- dateExamplesConnection emptyNotificationCallback

@@ -55,4 +62,4 @@ testDBCFunctionWithAtomArguments = TestCase $ do

5562 assertEqual "person relation" expectedPerson result

5663 expectTutorialDErr sess conn (T.isPrefixOf "AtomTypeMismatchError") "execute multiArgFunc(\"fail\", \"fail\")"

5764

58−

65+#endif

test/TutorialD/Interpreter/Import/ImportTest.hsnew file+47

@@ -0,0 +1,47 @@

1+import Test.HUnit

2+import ProjectM36.Base

3+import TutorialD.Interpreter.Import.TutorialD

4+import System.Exit

5+import qualified Data.Text as T

6+import System.IO.Temp

7+import System.FilePath

8+import qualified Data.Map as M

9+import System.IO

10+import System.Directory

11+import qualified Data.ByteString as BS

12+import qualified Data.Text.Encoding as TE

13+import Text.URI hiding (makeAbsolute)

14+

15+main :: IO ()

16+main = do

17+ tcounts <- runTestTT $ TestList [testTutdFileImport

18+ ,testTutdHTTPSImport

19+ ]

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

21+

22+testTutdFileImport :: Test

23+testTutdFileImport = TestCase $

24+ withSystemTempFile "m.tutd" $ \tempPath handle -> do

25+ BS.hPut handle (TE.encodeUtf8 "x:=relation{tuple{a 5,b \"spam\"}}; y:=relation{tuple{b \"漢字\"}}")

26+ hClose handle

27+ let expectedExpr = MultipleExpr [

28+ Assign "x" (MakeRelationFromExprs Nothing

29+ $ TupleExprs () [TupleExpr (M.fromList [("a", NakedAtomExpr $ IntegerAtom 5),

30+ ("b", NakedAtomExpr $ TextAtom "spam")])]),

31+ Assign "y" (MakeRelationFromExprs Nothing

32+ $ TupleExprs () [TupleExpr (M.fromList [("b", NakedAtomExpr (TextAtom "漢字"))])])]

33+ --on Windows, the file URI should not include the drive letter "/c/Users..." -> "/Users"

34+ let uri = "file://" <> map (\c -> if c == '\\' then '/' else c) ( joinDrive "/" (dropDrive tempPath))

35+ fileURI <- mkURI (T.pack uri)

36+ imported <- importTutorialDFromFile fileURI Nothing

37+ assertEqual "import tutd" (Right expectedExpr) imported

38+

39+testTutdHTTPSImport :: Test

40+testTutdHTTPSImport = TestCase $ do

41+ uri <- mkURI "https://raw.githubusercontent.com/agentm/project-m36/master/test/TutorialD/Interpreter/Import/httpimporttest.tutd"

42+ let hash = "effe32b247586dc3ac0079fc241b9618d41d189afcaeb7907edbe5a8b45992a4"

43+ expected = Right (MultipleExpr [Assign "x" (RelationVariable "true" ()),Assign "y" (RelationVariable "false" ())])

44+ actual <- importTutorialDViaHTTP uri (Just hash)

45+ assertEqual "github https" expected actual

46+

47+

test/TutorialD/Interpreter/Import/TutorialD.hsdeleted−29

@@ -1,29 +0,0 @@

1−import Test.HUnit

2−import ProjectM36.Base

3−import TutorialD.Interpreter.Import.TutorialD

4−import System.Exit

5−import System.IO.Temp

6−import qualified Data.Map as M

7−import System.IO

8−import qualified Data.ByteString as BS

9−import qualified Data.Text.Encoding as TE

10−

11−main :: IO ()

12−main = do

13− tcounts <- runTestTT $ TestList [testTutdImport]

14− if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

15−

16−testTutdImport :: Test

17−testTutdImport = TestCase $

18− withSystemTempFile "m.tutd" $ \tempPath handle -> do

19− BS.hPut handle (TE.encodeUtf8 "x:=relation{tuple{a 5,b \"spam\"}}; y:=relation{tuple{b \"漢字\"}}")

20− hClose handle

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 "漢字"))])])]

27− imported <- importTutorialD tempPath

28− assertEqual "import tutd" (Right expectedExpr) imported

29−

test/TutorialD/Interpreter/Import/httpimporttest.tutdnew file+2

@@ -0,0 +1,2 @@

1+x:=true;

2+y:=false;

test/TutorialD/Interpreter/TestBase.hs+8−8

@@ -28,13 +28,13 @@ executeTutorialD sessionId conn tutd = case parseTutorialD tutd of

2828 Right parsed -> do

2929 result <- evalTutorialD sessionId conn UnsafeEvaluation parsed

3030 case result of

31− QuitResult -> putStrLn "yyy" >> assertFailure "quit?"

32− DisplayResult _ -> putStrLn "xxx" >> assertFailure "display?"

33− DisplayIOResult _ -> putStrLn "z" >> assertFailure "displayIO?"

34− DisplayRelationResult _ -> putStrLn "Y" >> assertFailure "displayrelation?"

35− DisplayDataFrameResult _ -> putStrLn "DF" >> assertFailure "displaydataframe?"

36− DisplayParseErrorResult _ _ -> putStrLn "X" >> assertFailure "displayparseerrorresult?"

37− DisplayErrorResult err -> putStrLn "asd" >> assertFailure (show tutd ++ ": " ++ show err)

31+ QuitResult -> assertFailure "quit?"

32+ DisplayResult _ -> assertFailure "display?"

33+ DisplayIOResult _ -> assertFailure "displayIO?"

34+ DisplayRelationResult _ -> assertFailure "displayrelation?"

35+ DisplayDataFrameResult _ -> assertFailure "displaydataframe?"

36+ DisplayParseErrorResult _ _ -> assertFailure "displayparseerrorresult?"

37+ DisplayErrorResult err -> assertFailure (show tutd ++ ": " ++ show err)

3838 QuietSuccessResult -> pure ()

3939

4040expectTutorialDErr :: SessionId -> Connection -> (Text -> Bool) -> Text -> IO ()

@@ -49,7 +49,7 @@ expectTutorialDErr sessionId conn matchFunc tutd = case parseTutorialD tutd of

4949 DisplayRelationResult _ -> assertFailure "displayrelation?"

5050 DisplayDataFrameResult _ -> assertFailure "displaydataframe?"

5151 DisplayParseErrorResult _ _ -> assertFailure "displayparseerrorresult?"

52− DisplayErrorResult err -> assertBool ("match error on: " ++ unpack err) (matchFunc err)

52+ DisplayErrorResult err -> assertBool (unpack tutd ++ " match error on: " ++ unpack err) (matchFunc err)

5353 QuietSuccessResult -> pure ()

5454

5555eitherFail :: Either RelationalError a -> IO ()

test/TutorialD/Interpreter.hs → test/TutorialD/InterpreterTest.hsrenamed+78−13

@@ -41,8 +41,8 @@ main = do

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

4242 where

4343 tests = [

44− simpleRelTests

45−{- dateExampleRelTests,

44+ simpleRelTests,

45+ dateExampleRelTests,

4646 transactionGraphBasicTest,

4747 transactionGraphAddCommitTest,

4848 transactionRollbackTest,

@@ -75,13 +75,20 @@ main = do

7575 testNonEmptyListType,

7676 testUnresolvedAtomTypes,

7777 testWithClause,

78− testAtomFunctionArgumentMismatch-}

78+ testAtomFunctionArgumentMismatch,

79+ testInvalidDataConstructor,

80+ testBasicList,

81+ testRelationDeclarationMismatch,

82+ testInvalidTuples,

83+ testSelfReferencingUncommittedContext,

84+ testUnionAndIntersectionAttributeExprs

7985 ]

8086

8187simpleRelTests :: Test

8288simpleRelTests = TestCase $ do

8389 (graph, transId) <- freshTransactionGraph dateExamples

84− mapM_ (\(tutd, expected) -> assertTutdEqual basicDatabaseContext transId graph expected tutd) testTups

90+ mapM_ (\(tutd, expected) ->

91+ assertTutdEqual basicDatabaseContext transId graph expected tutd) testTups

8592 where

8693 testTups = [("x:=true", Right relationTrue),

8794 ("x:=false", Right relationFalse),

@@ -116,7 +123,8 @@ simpleRelTests = TestCase $ do

116123 ("x:=relation{tuple{a 5}} : {b:=6}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 6])]),

117124 ("x:=relation{tuple{a 5}} : {b:=add(@a,5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 10])]),

118125 ("x:=relation{tuple{a 5}} : {b:=add(@a,\"spam\")}", Left (AtomFunctionTypeError "add" 2 IntegerAtomType TextAtomType)),

119− ("x:=relation{tuple{a 5}} : {b:=add(add(@a,2),5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 12])])

126+ ("x:=relation{tuple{a 5}} : {b:=add(add(@a,2),5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 12])]),

127+ ("x:=false:{a:=1,b:=2}", mkRelationFromTuples simpleDAttributes [])

120128 ]

121129 simpleAAttributes = A.attributesFromList [Attribute "a" IntegerAtomType]

122130 simpleBAttributes = A.attributesFromList [Attribute "d" IntegerAtomType]

@@ -128,7 +136,8 @@ simpleRelTests = TestCase $ do

128136dateExampleRelTests :: Test

129137dateExampleRelTests = TestCase $ do

130138 (graph, transId) <- freshTransactionGraph dateExamples

131− mapM_ (\(tutd, expected) -> assertTutdEqual dateExamples transId graph expected tutd) testTups

139+ mapM_ (\(tutd, expected) ->

140+ assertTutdEqual dateExamples transId graph expected tutd) testTups

132141 where

133142 simpleEitherIntTextAttributes = A.attributesFromList [Attribute "a" (eitherAtomType IntegerAtomType TextAtomType)]

134143 maybeIntegerAtomType = ConstructedAtomType "Maybe" (M.singleton "a" IntegerAtomType)

@@ -146,7 +155,7 @@ dateExampleRelTests = TestCase $ do

146155 else Right tuple) suppliersRel

147156 extendTestAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" $ RelationAtomType (R.attributes suppliersRel)]

148157 testTups = [("x:=s where true", Right suppliersRel),

149− ("x:=s where city = \"London\"", restrict (\tuple -> pure $ atomForAttributeName "city" tuple == (Right $ TextAtom "London")) suppliersRel),

158+ ("x:=s where city = \"London\"", restrict (\tuple -> pure $ atomForAttributeName "city" tuple == Right (TextAtom "London")) suppliersRel),

150159 ("x:=s where false", Right $ Relation (R.attributes suppliersRel) emptyTupleSet),

151160 ("x:=p where color=\"Blue\" and city=\"Paris\"", mkRelationFromList (R.attributes productsRel) [[TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntegerAtom 12, TextAtom "Paris"]]),

152161 ("a:=s; update a (status:=50); x:=a{status}", mkRelation (A.attributesFromList [Attribute "status" IntegerAtomType]) (RelationTupleSet [mkRelationTuple (A.attributesFromList [Attribute "status" IntegerAtomType]) (V.fromList [IntegerAtom 50])])),

@@ -154,7 +163,7 @@ dateExampleRelTests = TestCase $ do

154163 --atom function tests

155164 ("x:=((s : {status2 := add(10,@status)}) where status2=add(10,@status)){city,s#,sname,status}", Right suppliersRel),

156165 ("x:=relation{tuple{a 5}} : {b:=s}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [IntegerAtom 5, RelationAtom suppliersRel])])),

157− ("x:=s; update x where sname=\"Blake\" (city:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "sname" tuple == (Right $ TextAtom "Blake") then Right $ updateTupleWithAtoms (M.singleton "city" (TextAtom "Boston")) tuple else Right tuple) suppliersRel),

166+ ("x:=s; update x where sname=\"Blake\" (city:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "sname" tuple == Right (TextAtom "Blake") then Right $ updateTupleWithAtoms (M.singleton "city" (TextAtom "Boston")) tuple else Right tuple) suppliersRel),

158167 ("x:=s; update x where city=\"Paris\" (status:=add(@status,10))", updateParisPlus10),

159168 --relatom function tests

160169 ("x:=((s group ({city} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (RelationTupleSet [mkRelationTuple groupCountAttrs (V.singleton $ IntegerAtom 1)])),

@@ -353,7 +362,7 @@ testComments :: Test

353362testComments = TestCase $ do

354363 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

355364 mapM_ (executeTutorialD sessionId dbconn) [

356− ":branch testbranch --test comment\n",

365+ ":branch testbranch --test comment",

357366 ":jumphead {- test comment -} master"]

358367

359368-- create a graph and query from two disparate contexts

@@ -491,16 +500,22 @@ testEmptyCommits = TestCase $ do

491500 assertEqual "empty insert empty commit" (Right False) dirty'

492501 Right () <- commit sessionId dbconn

493502

494− --update no tuples

503+ --update no tuples- since we defer the restriction, we can only assume the context is dirty, perhaps the constraint checker could offer an optimization here

495504 Right () <- executeDatabaseContextExpr sessionId dbconn (Update "s" (M.singleton "sname" (NakedAtomExpr (TextAtom "Bob"))) (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))

496505 dirty'' <- disconnectedTransactionIsDirty sessionId dbconn

497− assertEqual "empty update empty commit" (Right False) dirty''

506+ assertEqual "empty update empty commit" (Right True) dirty''

507+ Right () <- commit sessionId dbconn

508+

509+ --assign the same rel expr

510+ Right () <- executeDatabaseContextExpr sessionId dbconn (Assign "true" (ExistingRelation relationTrue))

511+ sameREdirty <- disconnectedTransactionIsDirty sessionId dbconn

512+ assertEqual "same relexpr assigned" (Right False) sameREdirty

498513 Right () <- commit sessionId dbconn

499514

500515 --delete no tuples

501516 Right () <- executeDatabaseContextExpr sessionId dbconn (Delete "s" (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))

502517 dirty''' <- disconnectedTransactionIsDirty sessionId dbconn

503− assertEqual "empty delete empty commit" (Right False) dirty'''

518+ assertEqual "empty delete empty commit" (Right True) dirty'''

504519

505520testIntervalAtom :: Test

506521testIntervalAtom = TestCase $ do

@@ -530,7 +545,7 @@ testListConstructedAtom = TestCase $ do

530545testTypeChecker :: Test

531546testTypeChecker = TestCase $ do

532547 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

533− let err1 = "AtomFunctionTypeError \"max\" 1 (RelationAtomType [Attribute \"_\" IntegerAtomType]) IntegerAtomType"

548+ let err1 = "AtomFunctionTypeError \"max\" 1"

534549 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a 0}}:{b:=max(@a)}"

535550

536551--exercise expression parser

@@ -650,6 +665,10 @@ testWithClause = TestCase $ do

650665 executeTutorialD sessionId dbconn "x:=with (x as s) x"

651666 eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())

652667 assertEqual "with x as s" (Right suppliersRel) eX

668+

669+ executeTutorialD sessionId dbconn "y:=with(a as true) (with (b as a) b)"

670+ eY <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())

671+ assertEqual "nested with" (Right relationTrue) eY

653672

654673 let err1 = "RelVarAlreadyDefinedError"

655674 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=with (s as s) s"

@@ -665,3 +684,49 @@ testAtomFunctionArgumentMismatch = TestCase $ do

665684 --wrong argument count

666685 let err2 = "FunctionArgumentCountMismatchError"

667686 expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "x:=relation{tuple{a 5}} where ^gt(@a,1,3)"

687+

688+testInvalidDataConstructor :: Test

689+testInvalidDataConstructor = TestCase $ do

690+ --test that a referenced TypeConstructor in a DataConstructor definition matches the expected count of arguments

691+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

692+ let err1 = "ConstructedAtomArgumentCountMismatchError"

693+ expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "data TestT = TestT Maybe Int"

694+

695+testBasicList :: Test

696+testBasicList = TestCase $ do

697+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

698+ executeTutorialD sessionId dbconn "x := relation{tuple{ a (Cons 1 (Cons 2 Empty)) }}"

699+

700+testRelationDeclarationMismatch :: Test

701+testRelationDeclarationMismatch = TestCase $ do

702+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

703+ expectTutorialDErr sessionId dbconn (T.isPrefixOf "AtomTypeMismatchError") "data A a = A a | B | C; a := relation{a A Integer}{tuple{a A \"1\"}}"

704+

705+--generate errors when the tuples in a new relation don't match

706+testInvalidTuples :: Test

707+testInvalidTuples = TestCase $ do

708+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

709+ expectTutorialDErr sessionId dbconn (T.isPrefixOf "AttributeNamesMismatchError") ":showexpr relation{tuple{a 1},tuple{b 2}}"

710+ expectTutorialDErr sessionId dbconn (T.isPrefixOf "AttributeNamesMismatchError") ":showexpr relation{tuple{a 1},tuple{a 2, b 3}}"

711+-- expectTutorialDErr sessionId dbconn (T.isPrefixOf "ParseErrorBundle") ":showexpr relation{tuple{a 2, a 3}}" --parse failure can't be validated with this function

712+

713+testSelfReferencingUncommittedContext :: Test

714+testSelfReferencingUncommittedContext = TestCase $ do

715+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

716+ executeTutorialD sessionId dbconn "s:=s union s"

717+ eS <- executeRelationalExpr sessionId dbconn (RelationVariable "s" ())

718+ _ <- rollback sessionId dbconn

719+ eSorig <- executeRelationalExpr sessionId dbconn (RelationVariable "s" ())

720+ assertEqual "s=s'" eSorig eS

721+

722+testUnionAndIntersectionAttributeExprs :: Test

723+testUnionAndIntersectionAttributeExprs = TestCase $ do

724+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

725+ executeTutorialD sessionId dbconn "x:=s{intersection of {all but sname} {sname}}"

726+ xRel <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())

727+ assertEqual "intersection attrs" (Right relationTrue) xRel

728+

729+ executeTutorialD sessionId dbconn "y:=s{union of {all but sname} {sname}}"

730+ yRel <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())

731+ assertEqual "union attrs" (Right suppliersRel) yRel

732+

test/TutorialD/PrinterTest.hsnew file+47

@@ -0,0 +1,47 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+import Test.HUnit

3+import ProjectM36.Base

4+import System.Exit

5+import Data.Text.Prettyprint.Doc

6+import Data.Map (fromList)

7+import TutorialD.Printer ()

8+import TutorialD.Interpreter.RelationalExpr

9+import Text.Megaparsec

10+import Data.Text (pack)

11+

12+testList :: Test

13+testList = TestList [

14+ testPretty "true" (RelationVariable "true" ()),

15+ testPretty "relation{tuple{a 3, b \"x\"}, tuple{a 4, b \"y\"}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",NakedAtomExpr (IntegerAtom 3)),("b",NakedAtomExpr (TextAtom "x"))]),TupleExpr (fromList [("a",NakedAtomExpr (IntegerAtom 4)),("b",NakedAtomExpr (TextAtom "y"))])])),

16+ testPretty "true:{a:=1, b:=1}" (Extend (AttributeExtendTupleExpr "b" (NakedAtomExpr (IntegerAtom 1))) (Extend (AttributeExtendTupleExpr "a" (NakedAtomExpr (IntegerAtom 1))) (RelationVariable "true" ()))),

17+ testPretty "relation{tuple{a fromGregorian(2014, 2, 4)}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",FunctionAtomExpr "fromGregorian" [NakedAtomExpr (IntegerAtom 2014),NakedAtomExpr (IntegerAtom 2),NakedAtomExpr (IntegerAtom 4)] ())])])),

18+ testPretty "relation{tuple{a bytestring(\"dGVzdGRhdGE=\")}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",FunctionAtomExpr "bytestring" [NakedAtomExpr (TextAtom "dGVzdGRhdGE=")] ())])])),

19+ testPretty "relation{tuple{a t}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",NakedAtomExpr (BoolAtom True))])])),

20+ testPretty "relation{tuple{a Cons 4 (Cons 5 Empty)}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",ConstructedAtomExpr "Cons" [NakedAtomExpr (IntegerAtom 4),ConstructedAtomExpr "Cons" [NakedAtomExpr (IntegerAtom 5),ConstructedAtomExpr "Empty" [] ()] ()] ())])])),

21+ testPretty "relation{a Int, b Text, c Bool}{}" (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "a" (ADTypeConstructor "Int" []) (),AttributeAndTypeNameExpr "b" (ADTypeConstructor "Text" []) (),AttributeAndTypeNameExpr "c" (ADTypeConstructor "Bool" []) ()]) (TupleExprs () [])),

22+ testPretty "relation{a relation{b Int}}{}" (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "a" (RelationAtomTypeConstructor [AttributeAndTypeNameExpr "b" (ADTypeConstructor "Int" []) ()]) ()]) (TupleExprs () []))

23+ ]

24+

25+main :: IO ()

26+main = do

27+ tcounts <- runTestTT testList

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

29+

30+testPretty :: String -> RelationalExpr -> Test

31+testPretty tutdStr relExprADT =

32+ TestCase $ do

33+ let relExprStr = show (pretty relExprADT)

34+ print relExprStr

35+ roundTrip <- parseRelExpr relExprStr

36+ {-tutdIn <- parseRelExpr tutdStr

37+ print ("tutd parsed", tutdIn)-}

38+ assertEqual ("pretty ADT " <> tutdStr) tutdStr relExprStr

39+ assertEqual ("round-trip " <> tutdStr) relExprADT roundTrip

40+

41+--round trip tutoriald

42+parseRelExpr :: String -> IO RelationalExpr

43+parseRelExpr tutdStr =

44+ case parse relExprP "test" (pack tutdStr) of

45+ Left err ->

46+ assertFailure (show err)

47+ Right parsed -> pure parsed

test/scripts.hs+5−2

@@ -4,6 +4,8 @@ import TutorialD.Interpreter.Import.TutorialD

44import System.Directory

55import Data.List (isSuffixOf)

66import System.Exit

7+import qualified Data.Text as T

8+import Text.URI

810testList :: IO Test

911testList = do

@@ -20,7 +22,8 @@ main = do

2022

2123testScript :: FilePath -> Test

2224testScript tutdFile = TestCase $ do

23− eImport <- importTutorialD tutdFile

25+ fileURI <- mkURI (T.pack ("file://" <> tutdFile))

26+ eImport <- importTutorialDFromFile fileURI Nothing

2427 case eImport of

2528 Left err -> assertFailure ("tutd import failure in " ++ tutdFile ++ ": " ++ show err)

26− Right _ -> pure ()

29+ Right _ -> pure ()