master..1b68b23 · project-m36

.github/workflows/ci.yaml+21−61

since splitsnapshots

unifiedsplit

@@ -6,64 +6,24 @@ jobs:

6 dockerimage:

7 runs-on: ubuntu-latest

8 steps:

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

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

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

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

11− with:

11+ with:

12− nix_path: nixpkgs=channel:nixos-unstable

12+ nix_path: nixpkgs=channel:nixos-unstable

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

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

14− with:

14+ with:

15− name: project-m36

15+ name: project-m36

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

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

17− - run: cachix use iohk

17+ - run: cachix use iohk

18− - name: docker load

18+ - name: docker load

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

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

20− - name: docker login

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

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

23− - name: docker tag with version

22+ - name: docker tag with version

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

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

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

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

26− - name: docker tag latest

25+ - name: docker tag latest

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

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

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

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

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

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

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

29+ 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−1

@@ -20,4 +20,3 @@ jupyter/build

20juyter/dist

21.ipynb_checkpoints

22project-m36.nix

23−stack.yaml

.travis.ymlnew file+60

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

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.8.4 STACK_YAML=stack.ghc8.8.yaml

20+ compiler: ": #stack 8.8.4"

21+

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

23+ compiler: ": #stack 8.6.5"

24+

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

26+ os: osx

27+ osx_image: xcode11

28+ compiler: ": #stack 8.6.5"

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.shnew file+25

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

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.shnew file+22

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

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.shnew file+16

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

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.shnew file+21

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

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.shnew file+27

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

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://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin;

14+}

15+

16+fetch_stack_linux() {

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

18+}

19+

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

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−4

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

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

2−

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

4−

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

1# 2020-12-27 (v0.9.0)

6

2

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

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

README.markdown+2−1

@@ -4,6 +4,7 @@

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

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

6[![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)

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

8[![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)

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

9

10

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

44

45

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

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

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

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

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

48+* IRC Channel: chat.freenode.net #project-m36

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

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

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

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

50

51

cabal.project−3

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

1packages: project-m36.cabal

2

3−package *

4− split-sections: True

5−

6--high-performance streaming library

3--high-performance streaming library

7source-repository-package

4source-repository-package

8 type: git

5 type: git

docker.nix+11−16

@@ -1,18 +1,13 @@

1−{ compiler ? "ghc8104"

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

1+{ pkgs ? import ./pkgs.nix }:

3−, pkgs ? import sources.nixpkgs { }

4−}:

5let

2let

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

3+ release = import ./release.nix { inherit pkgs; };

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

4+ static-project-m36 = pkgs.haskell.lib.justStaticExecutables release.project;

8in

5in

9−pkgs.dockerTools.buildImage {

6+ pkgs.dockerTools.buildImage {

10− name = "project-m36";

7+ name = "project-m36";

11− tag = "latest";

8+ tag = "latest";

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

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

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

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

14− config = {

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

11+ config = { Env = ["LC_ALL=en_US.UTF-8"];

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

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

17− };

18−}

13+ }

docs/15_minute_tutorial.markdown+1−1

@@ -28,7 +28,7 @@ Note that TutorialD is strongly-typed- no type coercions take place automaticall

28### Load the Canonical Chris Date Example

29

30```

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

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

32```

33

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.

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

9### Example Export

10

11```

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

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

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

14```

15```

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

37S6,Samson,100,New York

38```

39```

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

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

41TutorialD (master/main): :showexpr s

42┌──────────┬────────┬───────────┬───────────────┐

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

docs/introduction_to_the_relational_algebra.markdown+1−1

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

202

203(Course Relation)

204

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

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

206|-------------------------------|----------------------------------|--------------------------------------|

207|English 1|Steve|Room 104|

208|French 2|Bob|Room 103|

docs/reaching_out_of_the_tarpit.markdown+1−1

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

57To 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:

58

59```

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

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

61TutorialD (master/main): :showexpr p

62┌───────────────────┬────────────┬───────────────────┬────────────┬────────────┐

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

docs/tutd_cheatsheet.markdown+1−3

@@ -47,9 +47,7 @@ Database context expressions take the current database context as input and alte

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

50+|`:importexample date`|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`|

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

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

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

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

docs/tutd_tutorial.markdown+1−19

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

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

20

21```

22−:importexample cjdate

22+:importexample date

23```

24

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

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

30|p|parts|

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

32

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−

51### Types

33### Types

52

34

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

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

examples/Plantfarm.hsdeleted−446

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

1−{-# LANGUAGE DeriveGeneric #-}

2−

3−{-# LANGUAGE OverloadedStrings #-}

4−

5−{-# LANGUAGE DeriveAnyClass #-}

6−

7−{-# LANGUAGE DerivingVia #-}

8−

9−

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/out_of_the_tarpit.tutd+4−4

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

3data Address = Address Text

4data Agent = Agent Text

5data Name = Name Text

6−data Price = Price Integer --dollars

6+data Price = Price Double

7data RoomType = Kitchen | Bathroom | LivingRoom

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

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

9data AreaCode = City | Suburban | Rural

10data SpeedBand = VeryFast | Fast | Medium | Slow

11

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

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

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

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

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

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

61

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

63

64-- sample data

65

jupyter/TutorialD Notebook Walkthrough.ipynb+1−1

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

38 }

39 ],

40 "source": [

41− ":importexample cjdate"

41+ ":importexample date"

42 ]

43 },

44 {

nix/sources.jsondeleted−50

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

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.nixdeleted−171

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

1−# This file has been generated by Niv.

2−

3−let

4−

5− #

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

7− #

8−

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); }

pkgs.nixnew file+7

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

1+let

2+nixpkgs = builtins.fetchGit {

3+ url = "https://github.com/NixOS/nixpkgs";

4+ rev = "f58482658eabf7d695f45904ecbc5f49c19fef98";

5+};

6+in

7+import nixpkgs { config.allowBroken = true; }

project-m36.cabal+42−55

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

1Cabal-Version: 2.2

2Name: project-m36

3−Version: 0.9.3

3+Version: 0.9.2

4License: 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

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

6Build-Type: Simple

7Homepage: https://github.com/agentm/project-m36

8Bug-Reports: https://github.com/agentm/project-m36/issues

@@ -35,7 +35,7 @@ Flag haskell-scripting

35 Default: True

36

37Library

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

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.3, winery, curryer-rpc, network, async, vector-instances, recursion-schemes

39 if flag(haskell-scripting)

40 Build-Depends: ghc >= 8.2 && < 8.11

41 CPP-Options: -DPM36_HASKELL_SCRIPTING

@@ -63,7 +63,6 @@ Library

63 ProjectM36.AtomFunction,

64 ProjectM36.AtomFunctionError,

65 ProjectM36.ScriptSession,

66− ProjectM36.Shortcuts,

67 ProjectM36.DatabaseContextFunction,

66 ProjectM36.DatabaseContextFunction,

68 ProjectM36.DatabaseContextFunctionError,

67 ProjectM36.DatabaseContextFunctionError,

69 ProjectM36.DatabaseContextFunctionUtils,

68 ProjectM36.DatabaseContextFunctionUtils,

@@ -143,7 +142,7 @@ Library

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

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

144 Default-Language: Haskell2010

143 Default-Language: Haskell2010

145 Default-Extensions: OverloadedStrings, CPP

144 Default-Extensions: OverloadedStrings, CPP

146− if !flag(stack)

145+ if !flag(stack)

147 Build-Depends: deferred-folds

146 Build-Depends: deferred-folds

148

147

149Executable tutd

148Executable tutd

@@ -175,7 +174,7 @@ Executable tutd

175 directory,

174 directory,

176 filepath,

175 filepath,

177 temporary,

176 temporary,

178− megaparsec >= 5.2.0 && < 10,

177+ megaparsec >= 5.2.0 && < 9,

179 haskeline,

178 haskeline,

180 random, MonadRandom,

179 random, MonadRandom,

181 base64-bytestring,

180 base64-bytestring,

@@ -185,13 +184,7 @@ Executable tutd

185 list-t,

184 list-t,

186 parser-combinators,

185 parser-combinators,

187 curryer-rpc,

186 curryer-rpc,

188− prettyprinter,

187+ 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

195 Other-Modules: TutorialD.Interpreter,

188 Other-Modules: TutorialD.Interpreter,

196 TutorialD.Interpreter.Base,

189 TutorialD.Interpreter.Base,

197 TutorialD.Interpreter.DatabaseContextExpr,

190 TutorialD.Interpreter.DatabaseContextExpr,

@@ -237,6 +230,7 @@ Executable project-m36-server

237 optparse-applicative,

230 optparse-applicative,

238 hashable-time,

231 hashable-time,

239 time,

232 time,

233+ vector-binary-instances,

240 text,

234 text,

241 deepseq-generics,

235 deepseq-generics,

242 mtl,

236 mtl,

@@ -258,7 +252,7 @@ Executable project-m36-server

258Executable bigrel

252Executable bigrel

259 Default-Language: Haskell2010

253 Default-Language: Haskell2010

260 Default-Extensions: OverloadedStrings

254 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

255+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, 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,

256 Other-Modules: TutorialD.Interpreter.Base,

263 TutorialD.Interpreter.DatabaseContextExpr,

257 TutorialD.Interpreter.DatabaseContextExpr,

264 TutorialD.Interpreter.RelationalExpr,

258 TutorialD.Interpreter.RelationalExpr,

@@ -270,11 +264,11 @@ Executable bigrel

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

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

271

265

272Common commontest

266Common commontest

273− Default-Language: Haskell2010

267+ 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

268+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, 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

275 Default-Extensions: OverloadedStrings

269 Default-Extensions: OverloadedStrings

276 GHC-Options: -Wall -threaded

270 GHC-Options: -Wall -threaded

277− Hs-Source-Dirs: test, src/bin

271+ Hs-Source-Dirs: ./src/bin, ., test/

278

272

279Benchmark basic-benchmark

273Benchmark basic-benchmark

280 Default-Language: Haskell2010

274 Default-Language: Haskell2010

@@ -287,7 +281,7 @@ Benchmark basic-benchmark

287 if flag(profiler)

281 if flag(profiler)

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

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

289

283

290−--benchmark inserts, updates, deletes for a basic use-case to shake out any space leaks

284+--benchmark inserts, updates, deletes for a basic use-case to shake out any space leaks

291Benchmark update-exprs

285Benchmark update-exprs

292 Default-Language: Haskell2010

286 Default-Language: Haskell2010

293 Default-Extensions: OverloadedStrings

287 Default-Extensions: OverloadedStrings

@@ -302,64 +296,64 @@ Benchmark update-exprs

302Test-Suite test-tutoriald

296Test-Suite test-tutoriald

303 import: commontest

297 import: commontest

304 type: exitcode-stdio-1.0

298 type: exitcode-stdio-1.0

305− main-is: TutorialD/InterpreterTest.hs

299+ main-is: test/TutorialD/Interpreter.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

300 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

301+ 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, parser-combinators, prettyprinter

308

302

309Test-Suite test-tutoriald-atomfunctionscript

303Test-Suite test-tutoriald-atomfunctionscript

310 import: commontest

304 import: commontest

311 type: exitcode-stdio-1.0

305 type: exitcode-stdio-1.0

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

306 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

307+ main-is: test/TutorialD/Interpreter/AtomFunctionScript.hs

314

308

315Test-Suite test-tutoriald-databasecontextfunctionscript

309Test-Suite test-tutoriald-databasecontextfunctionscript

316 import: commontest

310 import: commontest

317 type: exitcode-stdio-1.0

311 type: exitcode-stdio-1.0

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

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

319− main-is: TutorialD/Interpreter/DatabaseContextFunctionScript.hs

313+ main-is: test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs

320

314

321Test-Suite test-relation

315Test-Suite test-relation

322 import: commontest

316 import: commontest

323 type: exitcode-stdio-1.0

317 type: exitcode-stdio-1.0

324− main-is: Relation/Basic.hs

318+ main-is: test/Relation/Basic.hs

325

319

326Test-Suite test-static-optimizer

320Test-Suite test-static-optimizer

327 import: commontest

321 import: commontest

328 type: exitcode-stdio-1.0

322 type: exitcode-stdio-1.0

329− main-is: Relation/StaticOptimizer.hs

323+ main-is: test/Relation/StaticOptimizer.hs

330

324

331Test-Suite test-transactiongraph-persist

325Test-Suite test-transactiongraph-persist

332 import: commontest

326 import: commontest

333 type: exitcode-stdio-1.0

327 type: exitcode-stdio-1.0

334− main-is: TransactionGraph/Persist.hs

328+ main-is: test/TransactionGraph/Persist.hs

335 Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer

329 Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer

336

330

337Test-Suite test-relation-import-csv

331Test-Suite test-relation-import-csv

338 import: commontest

332 import: commontest

339 type: exitcode-stdio-1.0

333 type: exitcode-stdio-1.0

340− main-is: Relation/Import/CSV.hs

334+ main-is: test/Relation/Import/CSV.hs

341

335

342Test-Suite test-tutoriald-import-tutoriald

336Test-Suite test-tutoriald-import-tutoriald

343 import: commontest

337 import: commontest

344 type: exitcode-stdio-1.0

338 type: exitcode-stdio-1.0

345− main-is: TutorialD/Interpreter/Import/ImportTest.hs

339+ main-is: test/TutorialD/Interpreter/Import/TutorialD.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

340 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

347

341

348Test-Suite test-relation-export-csv

342Test-Suite test-relation-export-csv

349 import: commontest

343 import: commontest

350 type: exitcode-stdio-1.0

344 type: exitcode-stdio-1.0

351− main-is: Relation/Export/CSV.hs

345+ main-is: test/Relation/Export/CSV.hs

352

346

353Test-Suite test-transactiongraph-merge

347Test-Suite test-transactiongraph-merge

354 import: commontest

348 import: commontest

355 type: exitcode-stdio-1.0

349 type: exitcode-stdio-1.0

356− main-is: TransactionGraph/Merge.hs

350+ main-is: test/TransactionGraph/Merge.hs

357

351

358

352

359Test-Suite test-prettyprinter

353Test-Suite test-prettyprinter

360 import: commontest

354 import: commontest

361 type: exitcode-stdio-1.0

355 type: exitcode-stdio-1.0

362− main-is: TutorialD/PrinterTest.hs

356+ main-is: test/TutorialD/Printer.hs

363 Other-Modules: TutorialD.Printer, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types

357 Other-Modules: TutorialD.Printer, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types

364

358

365benchmark bench

359benchmark bench

@@ -370,48 +364,41 @@ benchmark bench

370Test-Suite test-server

364Test-Suite test-server

371 import: commontest

365 import: commontest

372 type: exitcode-stdio-1.0

366 type: exitcode-stdio-1.0

373− main-is: Server/Main.hs

367+ main-is: test/Server/Main.hs

374

368

375

369

376Executable Example-SimpleClient

370Executable Example-SimpleClient

377 Default-Language: Haskell2010

371 Default-Language: Haskell2010

378 Default-Extensions: OverloadedStrings

372 Default-Extensions: OverloadedStrings

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

373+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, 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

380 Main-Is: examples/SimpleClient.hs

374 Main-Is: examples/SimpleClient.hs

381 GHC-Options: -Wall -threaded

375 GHC-Options: -Wall -threaded

382

376

383Executable Example-OutOfTheTarpit

377Executable Example-OutOfTheTarpit

384 Default-Language: Haskell2010

378 Default-Language: Haskell2010

385 Default-Extensions: OverloadedStrings

379 Default-Extensions: OverloadedStrings

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

380+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, 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

387 Main-Is: examples/out_of_the_tarpit.hs

381 Main-Is: examples/out_of_the_tarpit.hs

388 GHC-Options: -Wall -threaded

382 GHC-Options: -Wall -threaded

389

383

390Executable Example-Blog

384Executable Example-Blog

391 Default-Language: Haskell2010

385 Default-Language: Haskell2010

392 Default-Extensions: OverloadedStrings

386 Default-Extensions: OverloadedStrings

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

387+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, 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

394 Main-Is: examples/blog.hs

388 Main-Is: examples/blog.hs

395 GHC-Options: -Wall -threaded

389 GHC-Options: -Wall -threaded

396

390

397Executable Example-Hair

391Executable Example-Hair

398 Default-Language: Haskell2010

392 Default-Language: Haskell2010

399 Default-Extensions: OverloadedStrings

393 Default-Extensions: OverloadedStrings

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

394+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, 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

401 Main-Is: examples/hair.hs

395 Main-Is: examples/hair.hs

402 GHC-Options: -Wall -threaded

396 GHC-Options: -Wall -threaded

403

397

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−

411Executable Example-CustomTupleable

398Executable Example-CustomTupleable

412 Default-Language: Haskell2010

399 Default-Language: Haskell2010

413 Default-Extensions: OverloadedStrings

400 Default-Extensions: OverloadedStrings

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

401+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, 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

415 Main-Is: examples/CustomTupleable.hs

402 Main-Is: examples/CustomTupleable.hs

416 GHC-Options: -Wall -threaded

403 GHC-Options: -Wall -threaded

417

404

@@ -428,12 +415,12 @@ Executable Example-DerivingCustomTupleable

428Test-Suite test-scripts

415Test-Suite test-scripts

429 import: commontest

416 import: commontest

430 type: exitcode-stdio-1.0

417 type: exitcode-stdio-1.0

431− main-is: scripts.hs

418+ main-is: test/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

419 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

433

420

434Executable project-m36-websocket-server

421Executable project-m36-websocket-server

435 Default-Language: Haskell2010

422 Default-Language: Haskell2010

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

423+ 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

437 Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs

424 Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs

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

425 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

439 GHC-Options: -Wall -threaded

426 GHC-Options: -Wall -threaded

@@ -443,46 +430,46 @@ Executable project-m36-websocket-server

443Test-Suite test-websocket-server

430Test-Suite test-websocket-server

444 import: commontest

431 import: commontest

445 type: exitcode-stdio-1.0

432 type: exitcode-stdio-1.0

446− main-is: Server/WebSocket.hs

433+ main-is: test/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

434 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

448

435

449Test-Suite test-isomorphic-schemas

436Test-Suite test-isomorphic-schemas

450 import: commontest

437 import: commontest

451 type: exitcode-stdio-1.0

438 type: exitcode-stdio-1.0

452− main-is: IsomorphicSchema.hs

439+ main-is: test/IsomorphicSchema.hs

453

440

454Test-Suite test-atomable

441Test-Suite test-atomable

455 import: commontest

442 import: commontest

456 type: exitcode-stdio-1.0

443 type: exitcode-stdio-1.0

457− main-is: Relation/Atomable.hs

444+ main-is: test/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

445 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

459

446

460Test-Suite test-multiprocess-access

447Test-Suite test-multiprocess-access

461 import: commontest

448 import: commontest

462 type: exitcode-stdio-1.0

449 type: exitcode-stdio-1.0

463− main-is: MultiProcessDatabaseAccess.hs

450+ main-is: test/MultiProcessDatabaseAccess.hs

464

451

465Test-Suite test-transactiongraph-automerge

452Test-Suite test-transactiongraph-automerge

466 import: commontest

453 import: commontest

467 type: exitcode-stdio-1.0

454 type: exitcode-stdio-1.0

468− main-is: TransactionGraph/Automerge.hs

455+ main-is: test/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

456 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

470

457

471Test-Suite test-tupleable

458Test-Suite test-tupleable

472 import: commontest

459 import: commontest

473 type: exitcode-stdio-1.0

460 type: exitcode-stdio-1.0

474− main-is: Relation/Tupleable.hs

461+ main-is: test/Relation/Tupleable.hs

475

462

476Test-Suite test-client-simple

463Test-Suite test-client-simple

477 import: commontest

464 import: commontest

478− Main-Is: Client/Simple.hs

465+ Main-Is: test/Client/Simple.hs

479 type: exitcode-stdio-1.0

466 type: exitcode-stdio-1.0

480

467

481-- test for file handle leaks

468-- test for file handle leaks

482Executable handles

469Executable handles

483 Default-Language: Haskell2010

470 Default-Language: Haskell2010

484 Default-Extensions: OverloadedStrings

471 Default-Extensions: OverloadedStrings

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

472+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, 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

486 main-is: benchmark/Handles.hs

473 main-is: benchmark/Handles.hs

487 Other-Modules: TutorialD.Interpreter,

474 Other-Modules: TutorialD.Interpreter,

488 TutorialD.Interpreter.Base,

475 TutorialD.Interpreter.Base,

@@ -506,9 +493,9 @@ Executable handles

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

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

507 if flag(profiler)

494 if flag(profiler)

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

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

509−

496+

510Test-Suite test-dataframe

497Test-Suite test-dataframe

511 import: commontest

498 import: commontest

512 type: exitcode-stdio-1.0

499 type: exitcode-stdio-1.0

513− Main-Is: DataFrame.hs

500+ Main-Is: test/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

501 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.nix+108−16

@@ -1,30 +1,122 @@

1−{ compiler ? "ghc8104"

1+{ compiler ? "ghc865"

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

2+, pkgs ? import ./pkgs.nix

3−, pkgs ? import sources.nixpkgs { }

4}:

3}:

4+

5let

6+ inherit (pkgs.lib.trivial) flip pipe;

7+ inherit (pkgs.haskell.lib) appendPatch appendConfigureFlags;

6 doJailbreak = pkgs.haskell.lib.doJailbreak;

8 doJailbreak = pkgs.haskell.lib.doJailbreak;

7− needsCocoa = drv:

9+ dontHaddock = pkgs.haskell.lib.dontHaddock;

8− if pkgs.stdenv.isDarwin

10+ dontCheck = pkgs.haskell.lib.dontCheck;

9− then drv.overrideDerivation (old:

11+ streamly-master = pkgs.fetchFromGitHub {

10− { buildInputs = [ pkgs.darwin.apple_sdk.frameworks.Cocoa ] ++ old.buildInputs; }

12+ owner = "composewell";

11− )

13+ repo = "streamly";

12− else drv;

14+ rev = "ac3af8749194f1788704dda8667d0b3807075cc2";

15+ sha256 = "04d8fk654vawdfs0dfidmq2awwgwi8x44iv8r7vqz70zkcsd5fij";

16+ };

13

17

18+ distProcessPkg = pkg : dontHaddock (doJailbreak (dontCheck pkg));

19+ callHackageDirectWithOptions = {pkg,ver, sha256, options}:

20+ let pkgver = "${pkg}-${ver}";

21+ in

22+ haskellPackages.callCabal2nixWithOptions pkg (pkgs.fetchzip {

23+ url = "mirror://hackage/${pkgver}/${pkgver}.tar.gz";

24+ inherit sha256;

25+ }) options;

26+

14 haskellPackages = pkgs.haskell.packages.${compiler}.override {

27 haskellPackages = pkgs.haskell.packages.${compiler}.override {

15 overrides = self: super: {

28 overrides = self: super: {

16− curryer-rpc = self.callCabal2nix "curryer-rpc" sources.curryer { };

29+ rank1dynamic =

30+ distProcessPkg (self.callHackageDirect {

31+ pkg = "rank1dynamic";

32+ ver = "0.4.0";

33+ sha256 = "1x6p9z53s7xwp93jp4n1lq6m5xspcn6w62p461v8vqnp9600328b";

34+}{});

35+ stm-hamt =

36+ self.callHackageDirect {

37+ pkg = "stm-hamt";

38+ ver = "1.2.0.3";

39+ sha256 = "1i8j7q8nhx3l7gydrjlsyhkvllr6bppgrjf0hp38zpm7p6xcv2bb";

40+ }{};

41+

42+ stm-containers =

43+ self.callHackageDirect {

44+ pkg = "stm-containers";

45+ ver = "1.1.0.4";

46+ sha256 = "0h9z6lawdm44minx9spvdb7sp645l36ri5cnxvhrcxwzr64s7qb5";

47+ }{};

48+

49+ data-interval =

50+ self.callHackageDirect {

51+ pkg = "data-interval";

52+ ver = "2.0.1";

53+ sha256 = "085j4yjr8wimxampxqdrg47p577whwg2mjxgfdl44yfck52fb6an";

54+ }{};

55+

56+ curryer-rpc =

57+ self.callHackageDirect {

58+ pkg = "curryer-rpc";

59+ ver = "0.1";

60+ sha256 = "0vb7q68g4zjm20simnqpjdpvcvh4g8cwlc5b6zjdjpg1rargri41";

61+ }{};

62+

17− streamly = doJailbreak (needsCocoa (self.callCabal2nix "streamly" sources.streamly { }));

63+ streamly = self.callCabal2nix "streamly" streamly-master {};

64+

65+ fusion-plugin-types =

66+ self.callHackageDirect {

67+ pkg = "fusion-plugin-types";

68+ ver = "0.1.0";

69+ sha256 = "17211b80p4zqisghs2j8flm4dj788f9glx2id6nh8f223q4cigc9";

70+ }{};

71+

72+ winery =

73+ self.callHackageDirect {

74+ pkg = "winery";

75+ ver = "1.3.2";

76+ sha256 = "1jc7q8m0zd8bziwa3mra44j518ckc566akk7r5hqpf8x5ng0n4vv";

77+ }{};

78+

79+ barbies-th =

80+ self.callHackageDirect {

81+ pkg = "barbies-th";

82+ ver = "0.1.7";

83+ sha256 = "0gf39kcn6lwqhz888qm3iypma76yrp3zwmif1niry647qq27xp4j";

84+ }{};

85+

86+ barbies =

87+ self.callHackageDirect {

88+ pkg = "barbies";

89+ ver = "2.0.2.0";

90+ sha256 = "0753rd8pw0x1cgasz8a6633kg83jngwzncp9khbimllvcdqzardh";

91+ }{};

92+

93+ prettyprinter =

94+ self.callHackageDirect {

95+ pkg = "prettyprinter";

96+ ver = "1.7.0";

97+ sha256 = "17byy08brwcsl5rqdhibq3pcpgx085shizb2ap6s4xy3izdia3cc";

98+ }{};

99+

100+ prettyprinter-ansi-terminal =

101+ self.callHackageDirect {

102+ pkg = "prettyprinter-ansi-terminal";

103+ ver = "1.1.2";

104+ sha256 = "0lwcqndppw3jc55rlnn6sp76zmjx2yzl21g9jhg27k2rdnjwd7md";

105+ }{};

106+

18− project-m36 = ((self.callCabal2nixWithOptions "project-m36" ./. "-f-haskell-scripting" { }));

107+ project-m36 = dontCheck (self.callCabal2nixWithOptions "project-m36" ./. "-f-haskell-scripting" { });

108+

19 };

109 };

20 };

110 };

111+

112+ project = haskellPackages.project-m36;

21in

113in

22{

114{

23− project = haskellPackages.project-m36;

115+ project = project;

24

116

25 shell = haskellPackages.shellFor {

117 shell = haskellPackages.shellFor {

26− packages = p: [

118+ packages = p: with p; [

27− p.project-m36

119+ project

28 ];

120 ];

29 buildInputs = [

121 buildInputs = [

30 haskellPackages.ghcid

122 haskellPackages.ghcid

@@ -33,4 +125,4 @@ in

33 ];

125 ];

34 withHoogle = true;

126 withHoogle = true;

35 };

127 };

36−}

128+}

scripts/DateExamples.tutd+2−2

@@ -20,7 +20,7 @@ sp := relation{tuple{s# "S1",p# "P1",qty 300},

20 tuple{s# "S3",p# "P2",qty 200},

21 tuple{s# "S4",p# "P4",qty 300},

22 tuple{s# "S4",p# "P5",qty 400}};

23−key s_pkey {s#} s;

23+key s_pkey {s#} s

24−key p_key {p#} p;

24+key p_key {p#} p

25foreign key s_sp_fk sp{s#} in s{s#};

26foreign key p_sp_fk sp{p#} in p{p#};

scripts/multiline.tutddeleted−2

@@ -1,2 +0,0 @@

1−x:=relation{

2−tuple{ x 2}} -- nice

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs−3

@@ -164,9 +164,6 @@ instance FromJSON SchemaError

164instance ToJSON MergeError

165instance FromJSON MergeError

166

167−instance ToJSON ImportError'

168−instance FromJSON ImportError'

169−

170instance ToJSON DatabaseContextFunctionError

167instance ToJSON DatabaseContextFunctionError

171instance FromJSON DatabaseContextFunctionError

168instance FromJSON DatabaseContextFunctionError

172

169

src/bin/ProjectM36/Server/WebSocket.hs+1−2

@@ -22,7 +22,6 @@ import Data.Attoparsec.Text

22import Control.Applicative

23import Text.Megaparsec.Error

24import Data.Functor

25−import Data.Either (fromRight)

26

25

27#if MIN_VERSION_megaparsec(7,0,0)

26#if MIN_VERSION_megaparsec(7,0,0)

28import Data.List.NonEmpty as NE

27import Data.List.NonEmpty as NE

@@ -118,7 +117,7 @@ promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName)

118promptInfo sessionId conn = do

117promptInfo sessionId conn = do

119 eHeadName <- headName sessionId conn

118 eHeadName <- headName sessionId conn

120 eSchemaName <- currentSchemaName sessionId conn

119 eSchemaName <- currentSchemaName sessionId conn

121− pure (fromRight "<unknown>" eHeadName, fromRight "<no schema>" eSchemaName)

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

122

121

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

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

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

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

src/bin/ProjectM36/Server/WebSocket/websocket-client.html+1−1

@@ -126,7 +126,7 @@ margin-bottom: 5pt;

126 <li>:showrelvars</li>

127 <li>:showexpr true</li>

128 <li>:showexpr false</li>

129− <li>:importexample cjdate</li>

129+ <li>:importexample date</li>

130 <li>:showexpr s join sp</li>

131 <li>update s where city="Paris" (status:=10)</li>

132 <li>:showexpr s</li>

src/bin/ProjectM36/Server/WebSocket/websocket-server.hs+9−42

@@ -1,40 +1,23 @@

1{-# LANGUAGE CPP #-}

2−

2+import ProjectM36.Server.WebSocket

3+import ProjectM36.Server.Config

4+import ProjectM36.Server.ParseArgs

5+import ProjectM36.Server

3import Control.Concurrent

6import Control.Concurrent

7+import qualified Network.WebSockets as WS

4import Control.Exception

8import Control.Exception

5−import Control.Monad (when)

6−import Data.Maybe (isJust)

7−import Data.String (fromString)

8−import Network.HTTP.Types (status400)

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

19

10

20main :: IO ()

11main :: IO ()

21main = do

12main = do

22 -- launch normal project-m36-server

13 -- launch normal project-m36-server

23 addressMVar <- newEmptyMVar

14 addressMVar <- newEmptyMVar

24− wsConfig <- parseWSConfigWithDefaults (defaultServerConfig {bindPort = 8000, bindHost = "127.0.0.1"})

15+ serverConfig <- parseConfigWithDefaults (defaultServerConfig { bindPort = 8000, bindHost = "127.0.0.1" })

25−

26 --usurp the serverConfig for our websocket server and make the proxied server run locally

16 --usurp the serverConfig for our websocket server and make the proxied server run locally

27− let serverConfig = wsServerConfig wsConfig

28− wsHost = bindHost serverConfig

17+ let wsHost = bindHost serverConfig

29 wsPort = bindPort serverConfig

18 wsPort = bindPort serverConfig

30 serverHost = "127.0.0.1"

19 serverHost = "127.0.0.1"

31 serverConfig' = serverConfig {bindPort = 0, bindHost = serverHost}

20 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−

38 _ <- forkFinally (launchServer serverConfig' (Just addressMVar) >> pure ()) (either throwIO pure)

21 _ <- forkFinally (launchServer serverConfig' (Just addressMVar) >> pure ()) (either throwIO pure)

39 --wait for server to be listening

22 --wait for server to be listening

40 addr <- takeMVar addressMVar

23 addr <- takeMVar addressMVar

@@ -42,22 +25,6 @@ main = do

42 case addr of

25 case addr of

43 SockAddrInet port' _ -> fromIntegral port'

26 SockAddrInet port' _ -> fromIntegral port'

44 _ -> error "unsupported socket address (IPv4 only currently)"

27 _ -> error "unsupported socket address (IPv4 only currently)"

45− wsApp = websocketProxyServer port serverHost

28+ --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

46− waiApp = WS.websocketsOr defaultConnectionOptions wsApp backupApp

47− settings = warpSettings wsHost (fromIntegral wsPort)

29+ WS.runServer wsHost (fromIntegral wsPort) (websocketProxyServer port serverHost)

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"

55

30

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+1−3

@@ -34,7 +34,6 @@ import Data.Monoid

34import Data.List (isPrefixOf)

35import Control.Exception

36import System.Exit

37−import Data.Either (fromRight)

38

37

39{-

38{-

40context ops are read-only operations which only operate on the database context (relvars and constraints)

39context ops are read-only operations which only operate on the database context (relvars and constraints)

@@ -78,7 +77,7 @@ safeInterpreterParserP = fmap RODatabaseContextOp (roDatabaseContextOperatorP <*

78promptText :: Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType

77promptText :: Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType

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

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

80 where

79 where

81− transInfo = fromRight "<unknown>" eHeadName <> "/" <> fromRight "<no schema>" eSchemaName

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

82

81

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

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

84parseTutorialD = parse interpreterParserP ""

83parseTutorialD = parse interpreterParserP ""

@@ -216,7 +215,6 @@ evalTutorialDInteractive sessionId conn safe interactive expr = case expr of

216 unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited."

215 unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited."

217 barf :: RelationalError -> IO TutorialDOperatorResult

216 barf :: RelationalError -> IO TutorialDOperatorResult

218 barf (ScriptError (OtherScriptCompilationError errStr)) = pure (DisplayErrorResult (T.pack errStr))

217 barf (ScriptError (OtherScriptCompilationError errStr)) = pure (DisplayErrorResult (T.pack errStr))

219− barf (ParseError err) = pure (DisplayErrorResult err)

220 barf err = return $ DisplayErrorResult (T.pack (show err))

218 barf err = return $ DisplayErrorResult (T.pack (show err))

221 eHandler io = do

219 eHandler io = do

222 eErr <- io

220 eErr <- io

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

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

17import ProjectM36.DataFrame

18

19#if MIN_VERSION_megaparsec(6,0,0)

20−import Text.Megaparsec.Char

20+import Text.Megaparsec.Char

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

22import Text.Megaparsec

23import Data.Void

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

44import Data.Time.Clock

45import Data.Time.Format

46import Control.Monad (void)

47−import Data.Char

48

47

49#if !MIN_VERSION_megaparsec(7,0,0)

48#if !MIN_VERSION_megaparsec(7,0,0)

50anySingle :: Parsec Void Text (Token Text)

49anySingle :: Parsec Void Text (Token Text)

@@ -82,9 +81,8 @@ type ParseStr = Text

82type ParseStr = String

81type ParseStr = String

83#endif

82#endif

84

83

85−-- consumes only horizontal spaces

86spaceConsumer :: Parser ()

84spaceConsumer :: Parser ()

87−spaceConsumer = Lex.space space1 (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}")

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

88

86

89opChar :: Parser Char

87opChar :: Parser Char

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

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

@@ -137,9 +135,6 @@ arrow = symbol "->"

137semi :: Parser Text

135semi :: Parser Text

138semi = symbol ";"

136semi = symbol ";"

139

137

140−nline :: Parser Text

141−nline = (T.singleton <$> newline) <|> crlf

142−

143integer :: Parser Integer

138integer :: Parser Integer

144#if MIN_VERSION_megaparsec(6,0,0)

139#if MIN_VERSION_megaparsec(6,0,0)

145integer = Lex.signed (pure ()) Lex.decimal <* spaceConsumer

140integer = Lex.signed (pure ()) Lex.decimal <* spaceConsumer

@@ -155,7 +150,7 @@ natural = Lex.integer <* spaceConsumer

155#endif

150#endif

156

151

157float :: Parser Double

152float :: Parser Double

158−float = Lex.float <* spaceConsumer

153+float = Lex.float

159

154

160capitalizedIdentifier :: Parser Text

155capitalizedIdentifier :: Parser Text

161capitalizedIdentifier =

156capitalizedIdentifier =

@@ -205,9 +200,6 @@ normalQuotedString = quote *> (T.pack <$> manyTill Lex.charLiteral quote)

205quotedString :: Parser Text

200quotedString :: Parser Text

206quotedString = try tripleQuotedString <|> normalQuotedString

201quotedString = try tripleQuotedString <|> normalQuotedString

207

202

208−quoted :: Parser a -> Parser a

209−quoted = between quote quote

210−

211uuidP :: Parser U.UUID

203uuidP :: Parser U.UUID

212uuidP = do

204uuidP = do

213 uuidStart <- count 8 hexDigitChar

205 uuidStart <- count 8 hexDigitChar

@@ -236,10 +228,3 @@ colonOp :: Text -> Parser ()

236colonOp opStr = do

228colonOp opStr = do

237 _ <- string opStr <* (void spaceChar <|> eof) <* spaceConsumer

229 _ <- string opStr <* (void spaceChar <|> eof) <* spaceConsumer

238 pure ()

230 pure ()

239−

240−hex :: Parser Text

241−hex = takeWhileP (Just "hexadecimal")

242− (\c ->

243− isDigit c

244− || (c >= 'a' && c <= 'f'))

245−

src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+2−3

@@ -53,9 +53,8 @@ multilineSep :: Parser T.Text

53multilineSep = newline >> pure "\n"

54

55multipleDatabaseContextExprP :: Parser DatabaseContextExpr

56−multipleDatabaseContextExprP = do

56+multipleDatabaseContextExprP =

57− exprs <- filter (/= NoOperation) <$> sepBy1 databaseContextExprP semi

57+ MultipleExpr <$> sepBy1 databaseContextExprP semi

58− pure (MultipleExpr exprs)

59

58

60insertP :: Parser DatabaseContextExpr

59insertP :: Parser DatabaseContextExpr

61insertP = do

60insertP = do

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

@@ -2,8 +2,6 @@

2module TutorialD.Interpreter.Import.Base where

3import ProjectM36.Base

4import ProjectM36.Error

5−import Text.URI (URI)

6−import Data.Text (Text)

7#if __GLASGOW_HASKELL__ < 804

5#if __GLASGOW_HASKELL__ < 804

8import Data.Monoid

6import Data.Monoid

9#endif

7#endif

@@ -14,14 +12,11 @@ data RelVarDataImportOperator = RelVarDataImportOperator RelVarName FilePath (Re

14instance Show RelVarDataImportOperator where

12instance Show RelVarDataImportOperator where

15 show (RelVarDataImportOperator rv path _) = "RelVarDataImportOperator " <> show rv <> " " <> path

13 show (RelVarDataImportOperator rv path _) = "RelVarDataImportOperator " <> show rv <> " " <> path

16

14

17−type HashVerification = Maybe Text

18−

19-- | import data into a database context

15-- | import data into a database context

20−data DatabaseContextDataImportOperator = DatabaseContextDataImportOperator URI HashVerification (URI -> HashVerification -> IO (Either RelationalError DatabaseContextExpr))

16+data DatabaseContextDataImportOperator = DatabaseContextDataImportOperator FilePath (FilePath -> IO (Either RelationalError DatabaseContextExpr))

21

17

22instance Show DatabaseContextDataImportOperator where

18instance Show DatabaseContextDataImportOperator where

23− show (DatabaseContextDataImportOperator uri hash _) =

19+ show (DatabaseContextDataImportOperator path _) = "DatabaseContextDataImportOperator " <> path

24− "DatabaseContextDataImportOperator " <> show uri <> " " <> show hash

25

20

26-- perhaps create a structure to import a whole transaction graph section in the future

21-- perhaps create a structure to import a whole transaction graph section in the future

27

22

@@ -29,4 +24,4 @@ evalRelVarDataImportOperator :: RelVarDataImportOperator -> TypeConstructorMappi

29evalRelVarDataImportOperator (RelVarDataImportOperator relVarName path importFunc) tConsMap attrs = importFunc relVarName tConsMap attrs path

24evalRelVarDataImportOperator (RelVarDataImportOperator relVarName path importFunc) tConsMap attrs = importFunc relVarName tConsMap attrs path

30

25

31evalDatabaseContextDataImportOperator :: DatabaseContextDataImportOperator -> IO (Either RelationalError DatabaseContextExpr)

26evalDatabaseContextDataImportOperator :: DatabaseContextDataImportOperator -> IO (Either RelationalError DatabaseContextExpr)

32−evalDatabaseContextDataImportOperator (DatabaseContextDataImportOperator uri hash importFunc) = importFunc uri hash

27+evalDatabaseContextDataImportOperator (DatabaseContextDataImportOperator path importFunc) = importFunc path

src/bin/TutorialD/Interpreter/Import/BasicExamples.hs+2−2

@@ -20,8 +20,8 @@ importBasicExampleOperatorP :: Parser ImportBasicExampleOperator

20importBasicExampleOperatorP = do

21 reservedOp ":importexample"

22 example <- identifier

23− if example == "cjdate" then

23+ if example == "date" then

24 pure ImportBasicDateExampleOperator

25 else

26 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

14 --TODO: handle filesystem errors

15 csvData <- try (BS.readFile pathIn) :: IO (Either IOError BS.ByteString)

16 case csvData of

17− Left err -> pure $ Left (ImportError (ImportFileError (T.pack (show err))))

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

18 Right csvData' -> case csvAsRelation attrs tConsMap csvData' of

19− Left err -> pure $ Left (ParseError $ T.pack (show err))

19+ Left err -> return $ Left (ParseError $ T.pack (show err))

20− Right csvRel -> pure $ Right (Insert relVarName (ExistingRelation csvRel))

20+ Right csvRel -> return $ Right (Insert relVarName (ExistingRelation csvRel))

21

22importCSVP :: Parser RelVarDataImportOperator

23importCSVP = do

src/bin/TutorialD/Interpreter/Import/TutorialD.hs+17−70

@@ -9,78 +9,25 @@ import qualified Data.Text as T

9import Control.Exception

10import qualified Data.ByteString as BS

11import qualified Data.Text.Encoding as TE

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

12+--import a file containing TutorialD database context expressions

19

13

20−importTutorialDFromFile :: URI -> HashVerification -> IO (Either RelationalError DatabaseContextExpr)

14+importTutorialD :: FilePath -> IO (Either RelationalError DatabaseContextExpr)

21−importTutorialDFromFile fileURI mHash = do

15+importTutorialD pathIn = do

22− case URI.uriPath fileURI of

23− Just (False, _) -> do

24− eTutdBytes <- try (BS.readFile filePath) :: IO (Either IOError BS.ByteString)

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

25− case eTutdBytes of

17+ case eTutdBytes of

26− Left err -> pure $ Left (ImportError (ImportFileError (T.pack (show err))))

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

27− Right tutdBytes ->

19+ 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

20+ case TE.decodeUtf8' tutdBytes of

39− Left err -> pure (Left (ImportError (ImportFileDecodeError (T.pack (show err)))))

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

40− Right tutdUtf8 ->

22+ Right tutdUtf8 ->

41− case parse (multipleDatabaseContextExprP <* eof) "import" tutdUtf8 of

23+ case parse multipleDatabaseContextExprP "import" tutdUtf8 of

42− --parseErrorPretty is new in megaparsec 5

24+ --parseErrorPretty is new in megaparsec 5

43− Left err -> pure (Left (PM36E.ParseError (T.pack (errorBundlePretty err))))

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

44− Right expr -> pure (Right expr)

26+ Right expr -> pure (Right expr)

45−

27+

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−

75tutdImportP :: Parser DatabaseContextDataImportOperator

28tutdImportP :: Parser DatabaseContextDataImportOperator

76tutdImportP = do

29tutdImportP = do

77 reserved ":importtutd"

30 reserved ":importtutd"

78− uri <- quoted URI.parser

31+ path <- quotedString

79 spaceConsumer

32 spaceConsumer

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

33+ return $ DatabaseContextDataImportOperator (T.unpack path) importTutorialD

src/bin/TutorialD/Interpreter/RelationalExpr.hs+2−3

@@ -216,7 +216,6 @@ consumeAtomExprP consume = try functionAtomExprP <|>

216 attributeAtomExprP <|>

217 try nakedAtomExprP <|>

218 relationalAtomExprP

219−

220

219

221attributeAtomExprP :: Parser (AtomExprBase a)

220attributeAtomExprP :: Parser (AtomExprBase a)

222attributeAtomExprP = do

221attributeAtomExprP = do

@@ -235,7 +234,7 @@ constructedAtomExprP consume = do

235-- used only for primitive type parsing ?

234-- used only for primitive type parsing ?

236atomP :: Parser Atom

235atomP :: Parser Atom

237atomP = stringAtomP <|>

236atomP = stringAtomP <|>

238− try doubleAtomP <|>

237+ doubleAtomP <|>

239 integerAtomP <|>

238 integerAtomP <|>

240 boolAtomP

239 boolAtomP

241

240

@@ -250,7 +249,7 @@ stringAtomP :: Parser Atom

250stringAtomP = TextAtom <$> quotedString

249stringAtomP = TextAtom <$> quotedString

251

250

252doubleAtomP :: Parser Atom

251doubleAtomP :: Parser Atom

253−doubleAtomP = DoubleAtom <$> float

252+doubleAtomP = DoubleAtom <$> try float

254

253

255integerAtomP :: Parser Atom

254integerAtomP :: Parser Atom

256integerAtomP = IntegerAtom <$> integer

255integerAtomP = IntegerAtom <$> integer

src/lib/ProjectM36/Attribute.hs+6−6

@@ -87,12 +87,12 @@ joinAttributes attrs1 attrs2 | V.length uniqueOverlappingAttributes /= V.length

87 overlappingAttributes = V.filter (`V.elem` attrs2) attrs1

88-}

89joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes

90−joinAttributes attrs1 attrs2

90+joinAttributes attrs1 attrs2 =

91− | S.size overlappingNames == 0 = -- fast path, no overlapping names

91+ if S.size overlappingNames == 0 then -- fast path, no overlapping names

92 pure (concated id)

93− | attributesForNames overlappingNames attrs1 == attributesForNames overlappingNames attrs2 = -- that atomtypes match

93+ else if attributesForNames overlappingNames attrs1 == attributesForNames overlappingNames attrs2 then -- check that atomtypes match

94 pure (concated vectorUniqueify)

95− | otherwise =

95+ else

96 --special handling to validate that overlapping names have the same atom types

97 Left (TupleAttributeTypeMismatchError (attributesForNames overlappingNames attrs1))

98 where

@@ -111,7 +111,7 @@ member :: Attribute -> Attributes -> Bool

111member attr attrs = HS.member attr (attributesSet attrs)

112

113deleteAttributeName :: AttributeName -> Attributes -> Attributes

114−deleteAttributeName attrName = deleteAttributeNames (S.singleton attrName)

114+deleteAttributeName attrName attrs = deleteAttributeNames (S.singleton attrName) attrs

115

116deleteAttributeNames :: S.Set AttributeName -> Attributes -> Attributes

117deleteAttributeNames attrNames attrs = Attributes {

@@ -215,7 +215,7 @@ attributesDifference attrsA attrsB =

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)

218+ vec = V.filter (\attr -> HS.member attr hset) (attributesVec attrsA <> attributesVec attrsB)

219

220vectorUniqueify :: (Hash.Hashable a, Eq a) => V.Vector a -> V.Vector a

221vectorUniqueify vecIn = V.fromList $ HS.toList $ HS.fromList $ V.toList vecIn

src/lib/ProjectM36/Base.hs+2−2

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

1−{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable, DerivingVia, TemplateHaskell, TypeFamilies #-}

1+{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable, DerivingVia, TemplateHaskell, TypeFamilies, DeriveFoldable, DeriveTraversable #-}

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

3

4module ProjectM36.Base where

@@ -102,7 +102,7 @@ instance Hashable Attribute where

102type AttributesHash = Int

103

104-- | 'Attributes' represent the head of a relation.

105−newtype Attributes = Attributes {

105+data Attributes = Attributes {

106 attributesVec :: V.Vector Attribute

107 --,attributesSet :: HS.HashSet Attribute --compare with this generated in heap profile and benchmarks

108 }

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

@@ -248,7 +248,7 @@ createScriptSession :: [String] -> IO (Maybe ScriptSession)

248createScriptSession ghcPkgPaths = do

249 eScriptSession <- initScriptSession ghcPkgPaths

250 case eScriptSession of

251− Left err -> hPutStrLn stderr ("Warning: Haskell scripting disabled: " ++ show err) >> pure Nothing --not a fatal error, but the scripting feature must be disabled

251+ 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

252 Right s -> pure (Just s)

253

254

@@ -297,18 +297,16 @@ connectProjectM36 (RemoteConnectionInfo dbName hostName servicePort notification

297 \(NotificationMessage notifications') ->

298 forM_ (M.toList notifications') (uncurry notificationCallback)

299 ]

300− let connectExcHandler (e :: IOException) = pure $ Left (IOExceptionError e)

300+-- TODO missing async callback

301− eConn <- (Right <$> RPC.connect notificationHandlers (hostAddressToTuple addr) port) `catch` connectExcHandler

301+ conn <- RPC.connect notificationHandlers (hostAddressToTuple addr) port

302− case eConn of

303− Left err -> pure (Left err)

304− Right conn -> do

305− eRet <- RPC.call conn (Login dbName)

302+ eRet <- RPC.call conn (Login dbName)

303+-- TODO handle connection errors

306− case eRet of

304+ case eRet of

307− Left err -> error (show err)

305+ Left err -> error (show err)

308− Right False -> error "wtf"

306+ Right False -> error "wtf"

309− Right True ->

307+ Right True ->

310 --TODO handle connection errors!

308 --TODO handle connection errors!

311− pure (Right (RemoteConnection (RemoteConnectionConf conn)))

309+ pure (Right (RemoteConnection (RemoteConnectionConf conn)))

312

310

313--convert RPC errors into exceptions

311--convert RPC errors into exceptions

314convertRPCErrors :: RPC.ConnectionError -> IO a

312convertRPCErrors :: RPC.ConnectionError -> IO a

src/lib/ProjectM36/Error.hs+2−10

@@ -81,7 +81,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

81 | RelationValuedAttributesNotSupportedError [AttributeName]

82 | NotificationNameInUseError NotificationName

83 | NotificationNameNotInUseError NotificationName

84− | ImportError ImportError'

84+ | ImportError T.Text -- really? This should be broken out into some other error type- this has nothing to do with relational algebra

85 | ExportError T.Text

86 | UnhandledExceptionError String

87 | MergeTransactionError MergeError

@@ -144,12 +144,4 @@ data SchemaError = RelVarReferencesMissing (S.Set RelVarName) |

144 RelVarInReferencedMoreThanOnce RelVarName |

145 RelVarOutReferencedMoreThanOnce RelVarName

146 deriving (Show, Eq, Generic, Typeable, NFData)

147−

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/Relation.hs+2−2

@@ -244,8 +244,8 @@ relMap mapper (Relation attrs tupleSet) =

244

245relMogrify :: (RelationTuple -> Either RelationalError RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation

246relMogrify mapper newAttributes (Relation _ tupSet) = do

247+ newTuples <- mapM (\tup ->

247− newTuples <- mapM (fmap (reorderTuple newAttributes) . mapper) (asList tupSet)

248+ reorderTuple newAttributes <$> mapper tup) (asList tupSet)

248−

249 mkRelationFromTuples newAttributes newTuples

250

251relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a

src/lib/ProjectM36/RelationalExpression.hs+304−61

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

1{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE OverloadedStrings #-}

5module ProjectM36.RelationalExpression where

4module ProjectM36.RelationalExpression where

6import ProjectM36.Relation

5import ProjectM36.Relation

7import ProjectM36.Tuple

6import ProjectM36.Tuple

@@ -42,13 +41,14 @@ import ProjectM36.NormalizeExpr

42import ProjectM36.WithNameExpr

41import ProjectM36.WithNameExpr

43import Test.QuickCheck

42import Test.QuickCheck

44import qualified Data.Functor.Foldable as Fold

43import qualified Data.Functor.Foldable as Fold

45−import Control.Applicative

46#ifdef PM36_HASKELL_SCRIPTING

44#ifdef PM36_HASKELL_SCRIPTING

47import GHC hiding (getContext)

45import GHC hiding (getContext)

48import Control.Exception

46import Control.Exception

49import GHC.Paths

47import GHC.Paths

50#endif

48#endif

51

49

50+--import Debug.Trace

51+

52data DatabaseContextExprDetails = CountUpdatedTuples

53

54databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc

@@ -110,11 +110,11 @@ askEnv :: GraphRefRelationalExprM GraphRefRelationalExprEnv

110askEnv = R.ask

111

112mergeTuplesIntoGraphRefRelationalExprEnv :: RelationTuple -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv

113−mergeTuplesIntoGraphRefRelationalExprEnv tupIn env =

113+mergeTuplesIntoGraphRefRelationalExprEnv tupIn e =

114− env { gre_extra = new_elems }

114+ e{ gre_extra = new_elems }

115 where

116 new_elems = Just (Left newTuple)

117− mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple env))

117+ mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple e))

118 newTuple = mkRelationTupleFromMap mergedTupMap

119

120mergeAttributesIntoGraphRefRelationalExprEnv :: Attributes -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv

@@ -212,6 +212,160 @@ envContext = re_context

212setEnvContext :: RelationalExprEnv -> DatabaseContext -> RelationalExprEnv

213setEnvContext e ctx = e { re_context = ctx }

214

215+{-

216+--full evaluation down the graph

217+eval :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)

218+eval expr = do

219+ env <- askEnv

220+ eGfExpr <- processRelationalExpr expr

221+ case eGfExpr of

222+ Left err -> pure (Left err)

223+ Right gfExpr -> pure $ evalGraphRefRelationalExpr gfExpr (re_graph env)

224+-}

225+{-

226+--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values

227+evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError GraphRefRelationalExpr)

228+evalRelationalExpr (RelationVariable name _) = do

229+ relvarTable <- fmap (relationVariables . envContext) askEnv

230+ return $ case M.lookup name relvarTable of

231+ Just res -> Right res

232+ Nothing -> Left $ RelVarNotDefinedError name

233+

234+evalRelationalExpr (Project attrNames expr) = do

235+ eAttrNameSet <- evalAttributeNames attrNames expr

236+ case eAttrNameSet of

237+ Left err -> pure (Left err)

238+ Right attrNameSet -> do

239+ rel <- evalRelationalExpr expr

240+ case rel of

241+ Right rel2 -> pure $ Right (Project (AttributeNames attrNameSet) rel2)

242+ Left err -> pure $ Left err

243+

244+evalRelationalExpr (Union exprA exprB) = do

245+ relA <- evalRelationalExpr exprA

246+ relB <- evalRelationalExpr exprB

247+ case relA of

248+ Left err -> return $ Left err

249+ Right relA2 -> case relB of

250+ Left err -> return $ Left err

251+ Right relB2 -> return $ Right (Union relA2 relB2)

252+

253+evalRelationalExpr (Join exprA exprB) = do

254+ relA <- evalRelationalExpr exprA

255+ relB <- evalRelationalExpr exprB

256+ case relA of

257+ Left err -> return $ Left err

258+ Right relA2 -> case relB of

259+ Left err -> return $ Left err

260+ Right relB2 -> return $ Right (Join relA2 relB2)

261+

262+evalRelationalExpr (Difference exprA exprB) = do

263+ relA <- evalRelationalExpr exprA

264+ relB <- evalRelationalExpr exprB

265+ case relA of

266+ Left err -> return $ Left err

267+ Right relA2 -> case relB of

268+ Left err -> return $ Left err

269+ Right relB2 -> return $ Right (Difference relA2 relB2)

270+

271+evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) =

272+ case mkRelation attributeSet tupleSet of

273+ Right rel -> return $ Right (ExistingRelation rel)

274+ Left err -> return $ Left err

275+

276+evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

277+ currentContext <- fmap envContext askEnv

278+ let tConss = typeConstructorMapping currentContext

279+ -- 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

280+ runExceptT $ do

281+ mAttrs <- case mAttrExprs of

282+ Just _ ->

283+ Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)

284+ Nothing -> pure Nothing

285+ tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs

286+ let attrs = fromMaybe firstTupleAttrs mAttrs

287+ firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)

288+ expr <- either throwE pure (mkRelation attrs (RelationTupleSet tuples))

289+ pure (ExistingRelation expr)

290+

291+evalRelationalExpr (ExistingRelation rel) = pure (Right (ExistingRelation rel))

292+

293+evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do

294+ evald <- evalRelationalExpr relExpr

295+ case evald of

296+ Right expr -> return $ Right (Rename oldAttrName newAttrName expr)

297+ Left err -> return $ Left err

298+

299+evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do

300+ eOldAttrNameSet <- evalAttributeNames oldAttrNames relExpr

301+ case eOldAttrNameSet of

302+ Left err -> pure (Left err)

303+ Right oldAttrNameSet -> do

304+ evald <- evalRelationalExpr relExpr

305+ case evald of

306+ Right expr -> return $ Right (Group (AttributeNames oldAttrNameSet) newAttrName expr)

307+ Left err -> return $ Left err

308+

309+evalRelationalExpr (Ungroup attrName relExpr) = do

310+ evald <- evalRelationalExpr relExpr

311+ case evald of

312+ Right expr -> return $ Right (Ungroup attrName expr)

313+ Left err -> return $ Left err

314+

315+evalRelationalExpr (Restrict predicateExpr relExpr) = do

316+ evald <- evalRelationalExpr relExpr

317+ pred <- processRestrictionPredicateExpr predicateExpr

318+ case evald of

319+ Left err -> return $ Left err

320+ Right expr ->

321+ pure $ Right (Restrict pred expr)

322+

323+evalRelationalExpr (Equals relExprA relExprB) = do

324+ evaldA <- evalRelationalExpr relExprA

325+ evaldB <- evalRelationalExpr relExprB

326+ case evaldA of

327+ Left err -> return $ Left err

328+ Right exprA -> case evaldB of

329+ Left err -> return $ Left err

330+ Right exprB -> return $ Right (Equals exprA exprB)

331+{-

332+evalRelationalExpr (With views mainExpr) = do

333+ rstate <- ask

334+

335+ let addScopedView ctx (vname,vexpr) = if vname `M.member` relationVariables ctx then

336+ Left (RelVarAlreadyDefinedError vname)

337+ else

338+ case runState (evalDatabaseContextExpr (Assign vname vexpr)) (freshDatabaseState ctx) of

339+ (Left err,_) -> Left err

340+ (Right (), (ctx',_,_)) -> Right ctx'

341+

342+ case foldM addScopedView (stateElemsContext rstate) views of

343+ Left err -> return $ Left err

344+ Right ctx'' -> do

345+ let evalMainExpr expr = runReader (evalRelationalExpr expr) (RelationalExprEnv ctx'')

346+ case evalMainExpr mainExpr of

347+ Left err -> return $ Left err

348+ Right rel -> return $ Right rel

349+-}

350+--warning: copy-pasta from above- refactor

351+evalRelationalExpr (NotEquals relExprA relExprB) = do

352+ evaldA <- evalRelationalExpr relExprA

353+ evaldB <- evalRelationalExpr relExprB

354+ case evaldA of

355+ Left err -> return $ Left err

356+ Right exprA -> case evaldB of

357+ Left err -> return $ Left err

358+ Right exprB -> return $ Right (NotEquals exprA exprB)

359+

360+-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated

361+evalRelationalExpr (Extend tupleExpression relExpr) = do

362+ eExpr <- evalRelationalExpr relExpr

363+ case eExpr of

364+ Left err -> pure (Left err)

365+ Right expr -> do

366+ tupProc <- processExtendTupleExpr tupleExpression

367+ pure (Right (Extend tupProc expr))

368+-}

215--helper function to process relation variable creation/assignment

369--helper function to process relation variable creation/assignment

216setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()

370setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()

217setRelVar relVarName relExpr = do

371setRelVar relVarName relExpr = do

@@ -299,36 +453,20 @@ evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do

299

453

300evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do

454evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do

301 gfExpr <- relVarByName relVarName

455 gfExpr <- relVarByName relVarName

302− let optExpr = applyUnionCollapse (Union

456+ let optExpr = applyStaticUnionCollapse (Union

457+ gfExpr

303− relExpr

458+ relExpr)

304− gfExpr)

305 evalGraphRefDatabaseContextExpr (Assign relVarName optExpr)

459 evalGraphRefDatabaseContextExpr (Assign relVarName optExpr)

306

460

307evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do

461evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do

308 gfExpr <- relVarByName relVarName

462 gfExpr <- relVarByName relVarName

309− let optExpr = applyRestrictionCollapse (Restrict (NotPredicate predicate) gfExpr)

463+ setRelVar relVarName (Restrict (NotPredicate predicate) gfExpr)

310− setRelVar relVarName optExpr

311

464

312--union of restricted+updated portion and the unrestricted+unupdated portion

465--union of restricted+updated portion and the unrestricted+unupdated portion

313evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do

466evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do

314 rvExpr <- relVarByName relVarName

467 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

323 let unrestrictedPortion = Restrict (NotPredicate pred') rvExpr

468 let unrestrictedPortion = Restrict (NotPredicate pred') rvExpr

324− tmpAttr = tmpAttrC 1

469+ tmpAttr attr = "_tmp_" <> attr --this could certainly be improved to verify that there is no attribute name conflict

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

332 updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)

470 updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)

333 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)

471 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)

334 restrictedPortion = Restrict pred' rvExpr

472 restrictedPortion = Restrict pred' rvExpr

@@ -642,6 +780,18 @@ evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs

642 Left err -> pure (Left err)

780 Left err -> pure (Left err)

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

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

644

782

783+{-

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

785+updateTupleWithAtomExprs exprMap context graph tupIn = do

786+ --resolve all atom exprs

787+ let

788+ atomsAssoc <- mapM (\(attrName, atomExpr) -> do

789+ let atom = unimplemented

790+ --atom <- runReader (evalAtomExpr tupIn atomExpr) (mkRelationalExprState context graph)

791+ pure (attrName, atom)

792+ ) (M.toList exprMap)

793+ pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)

794+-}

645--run verification on all constraints

795--run verification on all constraints

646checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()

796checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()

647checkConstraints context transId graph@(TransactionGraph graphHeads transSet) = do

797checkConstraints context transId graph@(TransactionGraph graphHeads transSet) = do

@@ -693,6 +843,15 @@ typeForRelationalExpr expr = do

693 runGf = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

843 runGf = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

694 lift $ except runGf

844 lift $ except runGf

695

845

846+--returns a database context with all tuples removed

847+--this is useful for type checking and optimization

848+{-

849+contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext

850+contextWithEmptyTupleSets contextIn = contextIn { relationVariables = relVars }

851+ where

852+ relVars = M.map (\rel -> ExistingRelation (Relation (attributes rel) emptyTupleSet)) (relationVariables contextIn)

853+-}

854+

696liftE :: (Monad m) => m (Either a b) -> ExceptT a m b

855liftE :: (Monad m) => m (Either a b) -> ExceptT a m b

697liftE v = do

856liftE v = do

698 y <- lift v

857 y <- lift v

@@ -848,6 +1007,58 @@ evalGraphRefAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs _) = do

848 mapM (evalGraphRefAtomExpr tupIn) dConsArgs

1007 mapM (evalGraphRefAtomExpr tupIn) dConsArgs

849 pure (ConstructedAtom dConsName aType argAtoms)

1008 pure (ConstructedAtom dConsName aType argAtoms)

850

1009

1010+{-

1011+evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprM Atom

1012+evalAtomExpr tupIn expr =

1013+ -}

1014+{-

1015+

1016+evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of

1017+ Right atom -> pure (Right atom)

1018+ err@(Left (NoSuchAttributeNamesError _)) -> do

1019+ rstate <- ask

1020+ let stateTup = stateTuple rstate

1021+ pure (atomForAttributeName attrName stateTup)

1022+ Left err -> pure (Left err)

1023+evalAtomExpr _ (NakedAtomExpr atom) = pure (Right atom)

1024+evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do

1025+ argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn)) arguments

1026+ context <- fmap stateElemsContext ask

1027+ runExceptT $ do

1028+ let functions = atomFunctions context

1029+ func <- either throwE pure (atomFunctionForName funcName functions)

1030+ let expectedArgCount = length (atomFuncType func) - 1

1031+ actualArgCount = length argTypes

1032+ safeInit [] = [] -- different behavior from normal init

1033+ safeInit xs = init xs

1034+ if expectedArgCount /= actualArgCount then

1035+ throwE (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)

1036+ else do

1037+ let zippedArgs = zip (safeInit (atomFuncType func)) argTypes

1038+ mapM_ (\(expType, eActType) -> do

1039+ actType <- either throwE pure eActType

1040+ either throwE pure (atomTypeVerify expType actType)) zippedArgs

1041+ evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments

1042+ case evalAtomFunction func evaldArgs of

1043+ Left err -> throwE (AtomFunctionUserError err)

1044+ Right result -> do

1045+ --validate that the result matches the expected type

1046+ _ <- either throwE pure (atomTypeVerify (last (atomFuncType func)) (atomTypeForAtom result))

1047+ pure result

1048+evalAtomExpr tupIn (RelationAtomExpr relExpr) = do

1049+ --merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes

1050+ rstate <- ask

1051+ runExceptT $ do

1052+ let newState = mergeTuplesIntoRelationalExprState tupIn rstate

1053+ relAtom <- either throwE pure (runReader (evalRelationalExpr relExpr) newState)

1054+ pure (RelationAtom relAtom)

1055+evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExceptT $ do

1056+ rstate <- lift ask

1057+ let newState = mergeTuplesIntoRelationalExprState tupIn rstate

1058+ aType <- either throwE pure (runReader (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)

1059+ argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs

1060+ pure (ConstructedAtom dConsName aType argAtoms)

1061+-}

851typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType

1062typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType

852typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do

1063typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do

853 renv <- askEnv

1064 renv <- askEnv

@@ -914,7 +1125,7 @@ verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs tid) e

914 let handler :: RelationalError -> GraphRefRelationalExprM AtomType

1125 let handler :: RelationalError -> GraphRefRelationalExprM AtomType

915 handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName argCount expSubType actSubType)

1126 handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName argCount expSubType actSubType)

916 handler err = throwError err

1127 handler err = throwError err

917− verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler

1128+ verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler

918 funcArgTypes <- mapM funcArgVerifier $ zip3 funcArgExprs expectedArgTypes [1..]

1129 funcArgTypes <- mapM funcArgVerifier $ zip3 funcArgExprs expectedArgTypes [1..]

919 if length funcArgTypes /= length expectedArgTypes - 1 then

1130 if length funcArgTypes /= length expectedArgTypes - 1 then

920 throwError (AtomTypeCountError funcArgTypes expectedArgTypes)

1131 throwError (AtomTypeCountError funcArgTypes expectedArgTypes)

@@ -1017,6 +1228,56 @@ evalGraphRefTupleExpr mAttrs (TupleExpr tupMap) = do

1017-- _ <- lift $ except (validateTuple tup' tConss)

1228-- _ <- lift $ except (validateTuple tup' tConss)

1018 pure tup'

1229 pure tup'

1019

1230

1231+{-

1232+evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprM (Either RelationalError (S.Set AttributeName))

1233+evalAttributeNames attrNames expr = do

1234+ eExprType <- typeForRelationalExpr expr

1235+ case eExprType of

1236+ Left err -> throwError err

1237+ Right exprTyp -> do

1238+ let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))

1239+ case attrNames of

1240+ AttributeNames names ->

1241+ case A.projectionAttributesForNames names (attributes exprTyp) of

1242+ Left err -> pure (Left err)

1243+ Right attrs -> pure (Right (S.fromList (V.toList (A.attributeNames attrs))))

1244+

1245+ InvertedAttributeNames names -> do

1246+ let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet

1247+ if not (S.null nonExistentAttributeNames) then

1248+ pure (Left (AttributeNamesMismatchError nonExistentAttributeNames))

1249+ else

1250+ pure (Right (A.nonMatchingAttributeNameSet names typeNameSet))

1251+

1252+ UnionAttributeNames namesA namesB -> do

1253+ eNameSetA <- evalAttributeNames namesA expr

1254+ case eNameSetA of

1255+ Left err -> pure (Left err)

1256+ Right nameSetA -> do

1257+ eNameSetB <- evalAttributeNames namesB expr

1258+ case eNameSetB of

1259+ Left err -> pure (Left err)

1260+ Right nameSetB ->

1261+ pure (Right (S.union nameSetA nameSetB))

1262+

1263+ IntersectAttributeNames namesA namesB -> do

1264+ eNameSetA <- evalAttributeNames namesA expr

1265+ case eNameSetA of

1266+ Left err -> pure (Left err)

1267+ Right nameSetA -> do

1268+ eNameSetB <- evalAttributeNames namesB expr

1269+ case eNameSetB of

1270+ Left err -> pure (Left err)

1271+ Right nameSetB ->

1272+ pure (Right (S.intersection nameSetA nameSetB))

1273+

1274+ RelationalExprAttributeNames attrExpr -> do

1275+ eAttrExprType <- typeForRelationalExpr attrExpr

1276+ case eAttrExprType of

1277+ Left err -> pure (Left err)

1278+ Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))

1279+-}

1280+

1020--temporary implementation until we have a proper planner+executor

1281--temporary implementation until we have a proper planner+executor

1021evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation

1282evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation

1022evalGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

1283evalGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

@@ -1265,6 +1526,15 @@ evalRelationalExpr expr = do

1265 Left err -> throwError err

1526 Left err -> throwError err

1266 Right rel -> pure rel

1527 Right rel -> pure rel

1267

1528

1529+{-

1530+relVarByName :: RelVarName -> GraphRefRelationalExprM GraphRefRelationalExpr

1531+relVarByName = do

1532+ relvars <- relationVariables <$> getStateContext

1533+ case M.lookup relVarName relvars of

1534+ Nothing -> dbErr (RelVarNotDefinedError relVarName)

1535+ Just gfexpr -> pure gfExpr

1536+-}

1537+

1268class (MonadError RelationalError m, Monad m) => DatabaseContextM m where

1538class (MonadError RelationalError m, Monad m) => DatabaseContextM m where

1269 getContext :: m DatabaseContext

1539 getContext :: m DatabaseContext

1270

1540

@@ -1353,40 +1623,13 @@ instance ResolveGraphRefTransactionMarker GraphRefAtomExpr where

1353--convert series of simple Union queries into MakeStaticRelation

1623--convert series of simple Union queries into MakeStaticRelation

1354-- this is especially useful for long, nested applications of Union with simple tuples

1624-- 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')

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

1626+applyStaticUnionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr

1360−applyUnionCollapse = Fold.cata opt

1627+applyStaticUnionCollapse = Fold.cata opt

1361 where

1628 where

1362− opt :: RelationalExprBaseF GraphRefTransactionMarker GraphRefRelationalExpr -> GraphRefRelationalExpr

1363− opt (UnionF exprA exprB) | exprA == exprB = exprA

1364 opt (UnionF

1629 opt (UnionF

1365− exprA@(MakeRelationFromExprs mAttrs1 tupExprs1)

1630+ a@(MakeStaticRelation attrsA tupsA)

1366− exprB@(MakeRelationFromExprs mAttrs2 tupExprs2)) | tupExprs1 == tupExprs2 = MakeRelationFromExprs (mAttrs1 <|> mAttrs2) tupExprs1

1631+ b@(MakeStaticRelation attrsB tupsB)) = if attrsA == attrsB then

1367− | tupExprsNull tupExprs1 = exprB

1632+ MakeStaticRelation attrsA (tupleSetUnion attrsA tupsA tupsB)

1368− | tupExprsNull tupExprs2 = exprA

1633+ else

1634+ Union a b

1369 opt x = Fold.embed x

1635 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+2

@@ -128,6 +128,8 @@ initScriptSession ghcPkgPaths = do

128 "uuid",

129 "vector",

130 "text",

131+ "binary",

132+ "vector-binary-instances",

131 "time",

133 "time",

132 "project-m36",

134 "project-m36",

133 "bytestring"]

135 "bytestring"]

src/lib/ProjectM36/Serialise/Base.hs+4−3

@@ -10,10 +10,10 @@ import ProjectM36.MerkleHash

10import Data.UUID

11import Data.Proxy

12import Data.Word

13−import ProjectM36.Attribute as A

14import qualified Data.List.NonEmpty as NE

13import qualified Data.List.NonEmpty as NE

15import qualified Data.Vector as V

14import qualified Data.Vector as V

16import Data.Time.Calendar (Day,toGregorian,fromGregorian)

15import Data.Time.Calendar (Day,toGregorian,fromGregorian)

16+import qualified Data.HashSet as HS

17

18deriving via WineryVariant Atom instance Serialise Atom

19deriving via WineryVariant AtomType instance Serialise AtomType

@@ -77,9 +77,10 @@ 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+ let mkAttrs x = Attributes x (HS.fromList (V.toList x)) in

80− attributesFromList . V.toList <$> extractListBy extractor

81+ mkAttrs <$> extractListBy extractor

81

82

82 decodeCurrent = do

83 decodeCurrent = do

83 n <- decodeVarInt

84 n <- decodeVarInt

84 l <- replicateM n decodeCurrent

85 l <- replicateM n decodeCurrent

85− pure (A.attributesFromList l)

86+ pure (Attributes (V.fromList l) (HS.fromList l))

src/lib/ProjectM36/Serialise/Error.hs−1

@@ -12,4 +12,3 @@ deriving via WineryVariant MergeError instance Serialise MergeError

12deriving via WineryVariant ScriptCompilationError instance Serialise ScriptCompilationError

13deriving via WineryVariant PersistenceError instance Serialise PersistenceError

14deriving via WineryVariant SchemaError instance Serialise SchemaError

15−deriving via WineryVariant ImportError' instance Serialise ImportError'

src/lib/ProjectM36/Server/Config.hs−6

@@ -12,12 +12,6 @@ data ServerConfig = ServerConfig { persistenceStrategy :: PersistenceStrategy,

12 }

13 deriving (Show)

14

15−data WebsocketServerConfig = WebsocketServerConfig { wsServerConfig :: ServerConfig,

16− tlsCertificatePath :: Maybe String,

17− tlsKeyPath :: Maybe String

18− }

19− deriving (Show)

20−

21defaultServerConfig :: ServerConfig

15defaultServerConfig :: ServerConfig

22defaultServerConfig = ServerConfig { persistenceStrategy = NoPersistence,

16defaultServerConfig = ServerConfig { persistenceStrategy = NoPersistence,

23 checkFS = True,

17 checkFS = True,

src/lib/ProjectM36/Server/EntryPoints.hs+2−2

@@ -5,8 +5,8 @@ import ProjectM36.IsomorphicSchema

5import ProjectM36.Client as C

6import Data.Map

7import Control.Concurrent (threadDelay)

8−import Network.RPC.Curryer.Server

8+import Network.RPC.Curryer.Server

9−import System.Timeout hiding (Timeout)

9+import System.Timeout

10import Network.Socket

11import Control.Exception

12

src/lib/ProjectM36/Server/ParseArgs.hs+14−31

@@ -17,14 +17,14 @@ parseArgsWithDefaults defaults = ServerConfig <$>

17 many parseGhcPkgPath <*>

18 parseTimeout (perRequestTimeout defaults) <*>

19 parseTestMode

20−

20+

21parsePersistenceStrategy :: Parser PersistenceStrategy

22parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>

23 MinimalPersistence <$> dbdirOpt <|>

24 pure NoPersistence

25− where

25+ where

26− dbdirOpt = strOption (short 'd' <>

26+ dbdirOpt = strOption (short 'd' <>

27− long "database-directory" <>

27+ long "database-directory" <>

28 metavar "DIRECTORY" <>

29 showDefaultWith show

30 )

@@ -34,60 +34,43 @@ parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>

34

35parseTestMode :: Parser Bool

36parseTestMode = flag True False (long "test-mode" <> hidden)

37−

37+

38−parseCheckFS :: Parser Bool

38+parseCheckFS :: Parser Bool

39parseCheckFS = flag True False (long "disable-fscheck" <>

40 help "Disable filesystem check for journaling.")

41−

41+

42parseDatabaseName :: Parser DatabaseName

43parseDatabaseName = strOption (short 'n' <>

44 long "database" <>

45 metavar "DATABASE_NAME")

46

47−parseHostname :: Hostname -> Parser Hostname

47+parseHostname :: Hostname -> Parser Hostname

48parseHostname defHostname = strOption (short 'h' <>

49 long "hostname" <>

50 metavar "HOST_NAME" <>

51 value defHostname)

52−

52+

53parsePort :: Port -> Parser Port

54parsePort defPort = option auto (short 'p' <>

55 long "port" <>

56 metavar "PORT_NUMBER" <>

57 value defPort)

58−

58+

59parseGhcPkgPath :: Parser String

60parseGhcPkgPath = strOption (long "ghc-pkg-dir" <>

61 metavar "GHC_PACKAGE_DIRECTORY")

62−

62+

63−parseTimeout :: Int -> Parser Int

63+parseTimeout :: Int -> Parser Int

64parseTimeout defTimeout = option auto (long "timeout" <>

65 metavar "MICROSECONDS" <>

66 value defTimeout)

67

68parseConfig :: IO ServerConfig

69parseConfig = parseConfigWithDefaults defaultServerConfig

70−

70+

71parseConfigWithDefaults :: ServerConfig -> IO ServerConfig

72parseConfigWithDefaults defaults = execParser (info (parseArgsWithDefaults defaults <**> helpOption) idm)

73

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

91

74

92helpOption :: Parser (a -> a)

75helpOption :: Parser (a -> a)

93helpOption = abortOption helpText $ mconcat

76helpOption = abortOption helpText $ mconcat

@@ -97,6 +80,6 @@ helpOption = abortOption helpText $ mconcat

97 where

80 where

98#if MIN_VERSION_optparse_applicative(0,16,0)

81#if MIN_VERSION_optparse_applicative(0,16,0)

99 helpText = ShowHelpText Nothing

82 helpText = ShowHelpText Nothing

100−#else

83+#else

101 helpText = ShowHelpText

84 helpText = ShowHelpText

102#endif

85#endif

src/lib/ProjectM36/Shortcuts.hsdeleted−247

@@ -1,247 +0,0 @@

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+3−4

@@ -22,6 +22,8 @@ import qualified Data.Set as S

22

23-- the static optimizer performs optimizations which need not take any specific-relation statistics into account

24

25+--import Debug.Trace

26+

25data GraphRefSOptRelationalExprEnv =

27data GraphRefSOptRelationalExprEnv =

26 GraphRefSOptRelationalExprEnv

28 GraphRefSOptRelationalExprEnv

27 {

29 {

@@ -177,7 +179,7 @@ fullOptimizeGraphRefRelationalExpr expr = do

177optimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefSOptRelationalExprM GraphRefRelationalExpr

179optimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefSOptRelationalExprM GraphRefRelationalExpr

178optimizeGraphRefRelationalExpr e@(MakeStaticRelation _ _) = pure e

180optimizeGraphRefRelationalExpr e@(MakeStaticRelation _ _) = pure e

179

181

180−optimizeGraphRefRelationalExpr e@MakeRelationFromExprs{} = pure e

182+optimizeGraphRefRelationalExpr e@(MakeRelationFromExprs _ _) = pure e

181

183

182optimizeGraphRefRelationalExpr e@(ExistingRelation _) = pure e

184optimizeGraphRefRelationalExpr e@(ExistingRelation _) = pure e

183

185

@@ -207,8 +209,6 @@ optimizeGraphRefRelationalExpr (Union exprA exprB) = do

207 case (optExprA, optExprB) of

209 case (optExprA, optExprB) of

208 (Restrict predA (RelationVariable nameA sA),

210 (Restrict predA (RelationVariable nameA sA),

209 Restrict predB (RelationVariable nameB sB)) | nameA == nameB && sA == sB -> pure (Restrict (AndPredicate predA predB) (RelationVariable nameA sA))

211 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'

212 _ -> if optExprA == optExprB then

213 pure optExprA

214 else

@@ -575,4 +575,3 @@ applyStaticRestrictionPushdown expr = case expr of

575-- no optimizations available

576optimizeDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextIOExpr

577optimizeDatabaseContextIOExpr = pure

578−

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

@@ -384,7 +384,7 @@ subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans trav

384 else do

385 currentTransChildren <- childTransactions currentTrans' origGraph

386 let searchChildren = S.difference (S.insert currentTrans' traverseSet) currentTransChildren

387− searchChild start' = pathToTransaction origGraph start' goalTrans (S.insert currentTrans' traverseSet)

387+ searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans' traverseSet)

388 childSearches = map searchChild (S.toList searchChildren)

389 errors = lefts childSearches

390 pathsFound = rights childSearches

src/lib/ProjectM36/WithNameExpr.hs+2−4

@@ -42,11 +42,9 @@ substituteWithNameMacros macros (NotEquals exprA exprB) =

42substituteWithNameMacros macros (Extend extendTup expr) =

43 Extend (substituteWitNameMacrosExtendTupleExpr macros extendTup) (substituteWithNameMacros macros expr)

44substituteWithNameMacros macros (With moreMacros expr) =

45− --collect and update nested with exprs

45+ --collect and override existing macros and recurse

46 let newMacros = foldr macroFolder macros moreMacros

47− macroFolder (wnexpr, mexpr) acc =

47+ macroFolder (wnexpr, mexpr) acc = filter (\(w,_) -> w /= wnexpr) acc ++ [(wnexpr, mexpr)] in

48− let subExpr = substituteWithNameMacros macros mexpr in

49− filter (\(w,_) -> w /= wnexpr) acc ++ [(wnexpr, subExpr)] in

50 --scan for a match- if it exists, replace it (representing a with clause at a lower level

48 --scan for a match- if it exists, replace it (representing a with clause at a lower level

51 substituteWithNameMacros newMacros expr

49 substituteWithNameMacros newMacros expr

52

50

stack.ghc8.0.yamlnew file+48

@@ -0,0 +1,48 @@

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+- git: https://github.com/agentm/curryer.git

13+ commit: 1e60c0580ca33d6ae1e97aaddc32189fdfe3ef6c

14+- data-accessor-transformers-0.2.1.7

15+- data-interval-1.2.0

16+- extended-reals-0.2.1.0

17+- gnuplot-0.5.4.1

18+- text-1.2.2.1

19+- aeson-1.2.1.00

20+- deferred-folds-0.6.12

21+- rset-1.0.0

22+

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

24+flags: {}

25+

26+# Extra package databases containing global packages

27+extra-package-dbs: []

28+

29+# Control whether we use the GHC we find on the path

30+# system-ghc: true

31+

32+# Require a specific version of stack, using version ranges

33+# require-stack-version: -any # Default

34+# require-stack-version: >= 1.0.0

35+

36+# Override the architecture used by stack, especially useful on Windows

37+# arch: i386

38+# arch: x86_64

39+

40+# Extra directories used by stack for building

41+# extra-include-dirs: [/path/to/dir]

42+# extra-lib-dirs: [/path/to/dir]

43+

44+# Allow a newer minor version of GHC than the snapshot specifies

45+# compiler-check: newer-minor

46+

47+allow-newer: true

48+

stack.ghc8.10.yamldeleted−19

@@ -1,19 +0,0 @@

1−resolver: lts-17.13

2−packages:

3− - "."

4−

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.6.yaml+20−24

@@ -6,32 +6,28 @@ resolver: lts-14.27

6

7# Local packages, usually specified by relative directory name

8packages:

9− - "."

9+- '.'

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

11extra-deps:

12− - git: https://github.com/agentm/curryer.git

12+- git: https://github.com/agentm/curryer.git

13− commit: 74ecaac619ad1165a4517d5c0f4e530493bda130

13+ commit: 28ff1d031078af4a17fa326d43340474571df0c3

14− - git: https://github.com/composewell/streamly.git

14+- git: https://github.com/composewell/streamly.git

15− commit: ac3af8749194f1788704dda8667d0b3807075cc2

15+ commit: ac3af8749194f1788704dda8667d0b3807075cc2

16− - fast-builder-0.1.2.1

16+- fast-builder-0.1.2.1

17− - winery-1.3.2

17+- winery-1.3.2

18− - barbies-2.0.2.0

18+- barbies-2.0.2.0

19− - barbies-th-0.1.7

19+- barbies-th-0.1.7

20− - extended-reals-0.2.3.0

20+- extended-reals-0.2.3.0

21− - data-interval-2.0.1

21+- data-interval-2.0.1

22− - stm-containers-1.1.0.4

22+- stm-containers-1.1.0.4

23− - stm-hamt-1.2.0.4

23+- stm-hamt-1.2.0.4

24− - rset-1.0.0

24+- rset-1.0.0

25− - hashable-time-0.2.0.2

25+- hashable-time-0.2.0.2

26− - network-transport-tcp-0.6.0

26+- network-transport-tcp-0.6.0

27− - megaparsec-7.0.5

27+- megaparsec-7.0.5

28− - prettyprinter-1.7.0

28+- prettyprinter-1.7.0

29− - prettyprinter-ansi-terminal-1.1.2

29+- prettyprinter-ansi-terminal-1.1.2

30− - fusion-plugin-types-0.1.0

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

35

31

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

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

37flags:

33flags:

stack.ghc8.8.yaml+22−24

@@ -6,32 +6,30 @@ resolver: lts-16.4

6

7# Local packages, usually specified by relative directory name

8packages:

9− - "."

9+- '.'

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

11extra-deps:

12− - git: https://github.com/agentm/curryer.git

12+- git: https://github.com/agentm/curryer.git

13− commit: 74ecaac619ad1165a4517d5c0f4e530493bda130

13+ commit: 28ff1d031078af4a17fa326d43340474571df0c3

14− - git: https://github.com/composewell/streamly.git

14+- git: https://github.com/composewell/streamly.git

15− commit: ac3af8749194f1788704dda8667d0b3807075cc2

15+ commit: ac3af8749194f1788704dda8667d0b3807075cc2

16− - fast-builder-0.1.2.1

16+- fast-builder-0.1.2.1

17− - winery-1.3.2

17+- winery-1.3.2

18− - barbies-2.0.2.0

18+- barbies-2.0.2.0

19− - barbies-th-0.1.7

19+- barbies-th-0.1.7

20− - extended-reals-0.2.3.0

20+- extended-reals-0.2.3.0

21− - data-interval-2.0.1

21+- data-interval-2.0.1

22− - stm-containers-1.1.0.4

22+- stm-containers-1.1.0.4

23− - stm-hamt-1.2.0.4

23+- stm-hamt-1.2.0.4

24− - rset-1.0.0

24+- rset-1.0.0

25− - hashable-time-0.2.0.2

25+- hashable-time-0.2.0.2

26− - network-transport-tcp-0.7.0

26+- network-transport-tcp-0.7.0

27− - megaparsec-7.0.5

27+- megaparsec-7.0.5

28− - network-2.8.0.1

28+- network-2.8.0.1

29− - primitive-extras-0.8

29+- primitive-extras-0.8

30− - primitive-unlifted-0.1.3.0

30+- primitive-unlifted-0.1.3.0

31− - prettyprinter-1.7.0

31+- prettyprinter-1.7.0

32− - prettyprinter-ansi-terminal-1.1.2

32+- prettyprinter-ansi-terminal-1.1.2

33− - base16-bytestring-1.0.1.0

34− - modern-uri-0.3.4.0

35

33

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

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

37flags:

35flags:

test/Server/Main.hs+4−10

@@ -23,6 +23,8 @@ import System.FilePath

23import System.Directory

24#endif

25

26+import Debug.Trace

27+

26type Timeout = Int

28type Timeout = Int

27

29

28testList :: SessionId -> Connection -> MVar () -> Test

30testList :: SessionId -> Connection -> MVar () -> Test

@@ -42,7 +44,7 @@ testList sessionId conn notificationTestMVar = TestList $ serverTests ++ session

42 testRelationVariableSummary,

44 testRelationVariableSummary,

43 testNotification notificationTestMVar

45 testNotification notificationTestMVar

44 ]

46 ]

45− serverTests = [testRequestTimeout, testFileDescriptorCount, testClientConnectFail]

47+ serverTests = [testRequestTimeout, testFileDescriptorCount]

46

48

47main :: IO ()

49main :: IO ()

48main = do

50main = do

@@ -207,7 +209,7 @@ testRequestTimeout = TestCase $ do

207 case eTestConn of

209 case eTestConn of

208 Left err -> putStrLn ("failed to connect: " ++ show err) >> exitFailure

210 Left err -> putStrLn ("failed to connect: " ++ show err) >> exitFailure

209 Right (session, testConn) -> do

211 Right (session, testConn) -> do

210− res <- catchJust (\exc -> if exc == RequestTimeoutException then Just exc else Nothing) (callTestTimeout_ session testConn) (const (pure False))

212+ res <- catchJust (\exc -> if traceShowId exc == RequestTimeoutException then Just exc else Nothing) (callTestTimeout_ session testConn) (const (pure False))

211 assertBool "timeout exception was not thrown" (not res)

213 assertBool "timeout exception was not thrown" (not res)

212 killThread serverTid

214 killThread serverTid

213

215

@@ -238,11 +240,3 @@ fdCount = do

238--pass on non-linux platforms

240--pass on non-linux platforms

239testFileDescriptorCount = TestCase (pure ())

241testFileDescriptorCount = TestCase (pure ())

240#endif

242#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/TutorialD/InterpreterTest.hs → test/TutorialD/Interpreter.hsrenamed+1−5

@@ -362,7 +362,7 @@ testComments :: Test

362testComments = TestCase $ do

363 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

364 mapM_ (executeTutorialD sessionId dbconn) [

365− ":branch testbranch --test comment",

365+ ":branch testbranch --test comment\n",

366 ":jumphead {- test comment -} master"]

367

368-- create a graph and query from two disparate contexts

@@ -665,10 +665,6 @@ testWithClause = TestCase $ do

665 executeTutorialD sessionId dbconn "x:=with (x as s) x"

666 eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())

667 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

672

668

673 let err1 = "RelVarAlreadyDefinedError"

669 let err1 = "RelVarAlreadyDefinedError"

674 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=with (s as s) s"

670 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=with (s as s) s"

test/TutorialD/Interpreter/Import/ImportTest.hsdeleted−47

@@ -1,47 +0,0 @@

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.hsnew file+29

@@ -0,0 +1,29 @@

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+ $ TupleExprs () [TupleExpr (M.fromList [("a", NakedAtomExpr $ IntegerAtom 5),

24+ ("b", NakedAtomExpr $ TextAtom "spam")])]),

25+ Assign "y" (MakeRelationFromExprs Nothing

26+ $ TupleExprs () [TupleExpr (M.fromList [("b", NakedAtomExpr (TextAtom "漢字"))])])]

27+ imported <- importTutorialD tempPath

28+ assertEqual "import tutd" (Right expectedExpr) imported

29+

test/TutorialD/Interpreter/Import/httpimporttest.tutddeleted−2

@@ -1,2 +0,0 @@

1−x:=true;

2−y:=false;

test/TutorialD/PrinterTest.hs → test/TutorialD/Printer.hsrenamed

The content is the same.

test/scripts.hs+2−5

@@ -4,8 +4,6 @@ import TutorialD.Interpreter.Import.TutorialD

4import System.Directory

5import Data.List (isSuffixOf)

6import System.Exit

7−import qualified Data.Text as T

8−import Text.URI

9

7

10testList :: IO Test

8testList :: IO Test

11testList = do

9testList = do

@@ -22,8 +20,7 @@ main = do

22

20

23testScript :: FilePath -> Test

21testScript :: FilePath -> Test

24testScript tutdFile = TestCase $ do

22testScript tutdFile = TestCase $ do

25− fileURI <- mkURI (T.pack ("file://" <> tutdFile))

23+ eImport <- importTutorialD tutdFile

26− eImport <- importTutorialDFromFile fileURI Nothing

27 case eImport of

24 case eImport of

28 Left err -> assertFailure ("tutd import failure in " ++ tutdFile ++ ": " ++ show err)

25 Left err -> assertFailure ("tutd import failure in " ++ tutdFile ++ ": " ++ show err)

29− Right _ -> pure ()

26+ Right _ -> pure ()